! TOC:
! [1.] READ INFO AND GRIDS
! [2.] READ/WRITE INITIAL CONDITIONS
! [3.] DOMESTIC AGENT GIVEN CONTINUATION
! [4.] FUNCTIONS  FOR HOUSEHOLD
! [5.] LENDER  GIVEN CONTINUATION
! [6.] AGENT
! [7.] LENDER'S VALUE
! [8.] UPDATE PRICES
! [9.] Solve EQUIL PRICES
! [10.] NUMERICAL FUNCTIONS
! [11.] 2D GRAPHS
! [12.] SIMULATIONS AND DEFAULT EVENTS
! [13.] IRF
! [14.] CALIBRATION


MODULE mostly
    implicit none

    include 'mpif.h'  !include mpi library !mpi

	!******* variables related mpi ******* !mpi
	integer:: ierror !return error message from mpi subroutines
	integer:: id     !identification number of each processor
	integer:: nproc  !total number of processors
	integer,dimension(mpi_status_size):: mpi_status
	                 !used to store status of mpi_recv

  !******* file related: input/outputb *******
  integer, parameter:: defout=6

  integer::             nlines, ilines
  character (len=70)::  charline

  integer, parameter::  infile=20
  character (len=25)::  infname='input22.dat'

  character (len=25)::  outfname

  integer, parameter::  outfile1=21
  character (len=25)::  outfname1

  integer, parameter::  outfile2=22
  character (len=25)::  outfname2
  integer, parameter::  outfile3=23
  character (len=25)::  outfname3

  integer, parameter::  outfile4=24
  character (len=25)::  outfname4

  integer, parameter::  outfile5=25 !13apr13
  character (len=25)::  outfname5
  integer, parameter::  outfile6=26
  character (len=25)::  outfname6

  integer, parameter::  outfile7=27 !03feb15
  character (len=25)::  outfname7
  integer, parameter::  outfile8=28
  character (len=25)::  outfname8
  integer, parameter::  outfile9=29
  character (len=25)::  outfname9
  integer, parameter::  outfile10=210
  character (len=25)::  outfname10
  integer, parameter::  outfile11=211
  character (len=25)::  outfname11

  !controls of in/ouput
  integer :: readv, writev, readq, writeq
  integer :: readh, writeh !16sep12
  integer :: readBandD, writeBandD !13apr13
  integer :: finiteec
  integer :: niter_finiteec, niter_nofiniteec !05apr14
  integer :: barg_option  !20apr14
  integer :: readvND, readBND, readD01, writevND, writeBND, writeD01
  integer :: finiteecND
  integer :: nobuybacks !01dec15
  integer :: calibrcase
  !******* gral parameters *******
  integer, parameter:: prec=kind(1.d0) !prec=selected_real_kind(14) prec=selected_real_kind(15, 307) !27sep15 !prec=8 ! selected_real_kind(15, 307) !20feb15 prec=8    !prec=kind(1.d0)
  integer, parameter:: zeroi=0
  real(prec), parameter:: one=1.0_prec, zero=0.0_prec
  real(prec), parameter:: two=2.0_prec, three=3.0_prec
  real(prec), parameter:: huge=10000._prec

  !******* Grids *******
    real(prec), parameter:: closetozero=1.0E-06_prec, small=1.0E-06_prec
    real(prec) :: epshalf


    integer :: nB, nBneg, nBzero, jb
    real(prec) :: gridB_dist, Bmin
    real(prec), dimension(:), allocatable :: Bj(:)

    integer :: nD, nDzero, jd
    real(prec) :: gridD_dist, Dmin
    real(prec), dimension(:), allocatable :: Dj(:) !30may13

    integer :: nz, jz, jzpr
    real(prec), dimension(:), allocatable :: zj(:)

    integer :: nR, iR
    real(prec), dimension(:), allocatable :: Rbar(:) !16oct14

    integer :: ny, jy
    real(prec) :: gridy_dist, ymin, ymax
    real(prec), dimension(:), allocatable :: yj(:)

    integer :: nA, ja
    integer :: nAneg, nAzero !07apr13
    real(prec) :: gridA_dist, Amin                  !04oct12
    real(prec), dimension(:), allocatable :: Aj(:)

  !*******   Economic parameters *******
    real(prec) :: modelfreq
    real(prec) ::  sigma, beta, gamma_psi, q0, Rbar_aver !16oct14
    real(prec) :: transcost !01jun17
    real(prec) :: m_stochdisc !03jan18
    real(prec) :: upperdef !07jun13
    real(prec) :: Psimin !22jun13
    integer :: jzstar !01aug13
    real(prec) :: phi1 !01aug13
    real(prec) :: delta !24may13
    !real(prec) :: psi0 !10dec12
    real(prec), dimension(:), allocatable :: psi0(:) !10apr13
    real(prec), dimension(:), allocatable :: piz(:,:)
    real(prec), dimension(:), allocatable :: piR(:)    !16oct14
    real(prec) :: mu, chiB, sd_B, chiL, sd_L !23dec13
    real(prec) :: avereps, sdeps,lowereps, uppereps !01feb15
    integer :: nodes_eps, noise_epsV, noise_epsH, noise_epsQ !01feb15
    integer :: integGH !29mar15
    real(prec) :: varphi, barc !01may15
    real(prec) :: minimaldef !29may15
    real(prec) ::  gamma_psi_A, Psimin_A, target_Psimin_A  !07jun15

    real(prec) ::  rhoz, sdeta

    real(prec) :: zaver_glob

  !*******    Auxiliary variables: *******
  real(prec), dimension(:), allocatable :: zeros
  integer, dimension(1)::ishit
  integer :: noconv  !25mar13

  !******* Decision rules and value functions  *******
   real(prec), dimension(:), allocatable ::  uttarray(:,:)
   real(prec), dimension(:), allocatable ::  vexpD(:,:,:,:) !31may13
   real(prec), dimension(:), allocatable ::  vD(:,:,:), v(:,:,:)
   integer, dimension(:), allocatable    ::  locBD(:,:,:),locDD(:,:,:) !30may13
   real(prec), dimension(:), allocatable ::  qqtil(:,:,:)
   real(prec), dimension(:), allocatable:: qqtil_temp(:,:,:) !25mar13
   real(prec), dimension(:), allocatable ::  qq(:,:,:,:) !23dec13
!   real(prec), dimension(:), allocatable ::  loan_grid(:,:,:,:) !06aug14

   real(prec), dimension(:), allocatable ::  vDold(:,:,:)
   integer, dimension(:), allocatable    ::  locBDold(:,:,:),locDDold(:,:,:)

!05sep15   real(prec), dimension(:), allocatable ::  H(:,:,:), Hold(:,:,:), delta_Hexp(:,:,:) !16oct14 Hexp(:,:,:)
   real(prec), dimension(:), allocatable ::  H(:,:,:), Hold(:,:,:) !05sep15
   real(prec), dimension(:), allocatable ::  HD(:,:,:), HDold(:,:,:), HND(:,:,:), HNDold(:,:,:) !05sep15
   real(prec), dimension(:), allocatable ::  delta_HDexp(:,:,:)   , delta_HNDexp(:,:,:) !05sep15
   real(prec), dimension(:), allocatable :: HexpR(:,:,:) !23dec13

  real(prec), dimension(:), allocatable  :: q2d(:,:), v2d(:,:,:), H2d(:,:,:), qtil2d(:,:,:)
  real(prec), dimension(:), allocatable    ::  BD_c(:,:,:), DD_c(:,:,:), BD_cold(:,:,:), DD_cold(:,:,:)
!*temp  real(prec), dimension(:), allocatable    ::  vv_array(:,:)
  real(prec), dimension(:), allocatable    ::  vexpD_array(:,:,:,:) , uttD_array(:,:)

  real(prec), dimension(:), allocatable    ::  BND_c(:,:,:), BND_cold(:,:,:) !03feb15
  real(prec), dimension(:), allocatable ::  vexpND_array(:,:,:), uttND_array(:) !03feb15
  real(prec), dimension(:), allocatable ::  vND(:,:,:), vNDold(:,:,:) !03feb15
  integer, dimension(:), allocatable    ::  locBND(:,:,:), locBNDold(:,:,:) !03feb15

  integer, dimension(:), allocatable    ::  D01(:,:,:), D01old(:,:,:) !12feb15 !04feb15
  real(prec), dimension(:), allocatable    ::  B_c(:,:,:), D_c(:,:,:)

  !*******     Accuracies: *******
   integer :: errorjdec, dectol
   real(prec):: errmaxvD, errvD, vtol, speed_adjv, errmaxH, errH, Htol, speed_adjH !05feb14
   real(prec):: errmaxq, errq, speed_adjq, qtol
   real(prec) :: voldtol, tolall !24jun17 !13apr13
   real(prec):: speed_adjBD !22jul14
   real(prec)::  errmaxBD, errBD, errmaxDD, errDD !11aug14
   real(prec)::  errmaxBND, errBND !03feb15

   integer :: interp_vexp_c, interp_utt_c, interp_Hexp, interp_qqmap, optimproc
   integer :: optimprocND

   integer :: iter !22jul14
   integer ::  countshift !14aug14

   real(prec) :: rhobeg_opt, rhoend_opt !16feb15
   real(prec) :: tol0_opt, h0_opt    !23feb15
   real(prec) :: tol0_1dim, h0_1dim !23feb15

   integer :: draw_valD,ja_valD,jz_valD,jy_valD !17feb15
   integer :: draw_valND,ja_valND,jz_valND,jy_valND !17feb15
   real(prec) :: b_valD, d_valD
   integer :: draw_3period !03mar16
   integer :: dowelf !25oct21
   integer :: doIRF, doEVENT, dropjz_IRF
   integer :: ntimeIRF, npathsIRF
   integer :: lengthevent, maxlengthevent
   integer :: simulsize !18feb17
   integer :: do_counterfact

    integer :: use_tol_oldvsnew
    real(prec) :: tol_oldvsnew

    integer :: useD01old


  !******* calibration ************
  real(prec):: AtoY, Spr,freqdef, arrears  !04dec13
  real(prec) ::  corr_dspr, corrSpr, corr_sprtb, corr_dy, corr_tby !17oct14
  real(prec) :: d_stdv, spr_stdv !01apr16
  real(prec) :: debt_stdv !09oct17
  real(prec) :: sdC, qqaver
  real(prec) :: logy_corr, logy_var
  real(prec) :: debtserv, debtserv_sd !12oct21

  real(prec) :: d_stdv_noncond !05apr19

  integer :: step_calib !04dec13

  integer :: ifsmalldef !11may18
  real(prec) :: smalldef !11may18

    real(prec) :: a_aver2 !20sep14

    real(prec) ::  phi1_l, phi1_h, gamma_l,gamma_h, Psimin_l, Psimin_h, &
        &   beta_l, beta_h, & !18jan15 !13jan15
        &   Rbar_l, Rbar_h, &
        &   sdeta_l, sdeta_h

    real(prec), dimension(2) :: bbddl, bbddu         !15feb15

!14feb21
    real(prec) ::    AtoY_dat    , &
                  &  freqdef_dat  , &
                  &  arrears_dat  , &
                  &  sprstdv_dat  , &
                  &  debtstdv_dat , &
                  &  dstdv_dat    , &
                  &  corrSpr_dat  , &
                  &  Spr_dat      , &
                  &  sdC_dat      , &
                  &  smalldef_dat , &
                  & DebttoY_dat, &
                  & logy_corr_dat, logy_sd_dat, &
                  & debtserv_dat, debtserv_sd_dat !12oct21
   integer :: mv


    !****** MPI related ***********
    ! Creates mappings fro 1-dim array into state indexes
!mpi
  integer :: n_mpi, j_mpi
  integer, dimension(:), allocatable :: ja_mpi(:), jy_mpi(:), jz_mpi(:)

contains
  !
  !********************************************************************
  ! [1.] READ INFO AND GRIDS
  !********************************************************************

  subroutine readinfo
  implicit none
    open (infile, file=infname, status='old')
    read (infile, *) outfname

!11mar18 IF(ID==0) THEN !10jan18
    outfname1= 'f1_'//trim(outfname)//'.out'
    outfname2= 'f2_q_'//trim(outfname)//'.out'
    outfname3= 'f3_vD_'//trim(outfname)//'.out'
    outfname4= 'f4_h_'//trim(outfname)//'.out' !16sep12
    outfname5= 'f5_BD_'//trim(outfname)//'.out' !13apr13
    outfname6= 'f6_DD_'//trim(outfname)//'.out' !13apr13
    outfname7= 'f7_vND_'//trim(outfname)//'.out' !03feb15
    outfname8= 'f8_BND_'//trim(outfname)//'.out' !03feb15
    outfname9= 'f9_D01_'//trim(outfname)//'.out' !04feb15
    outfname10= 'f10_hND_'//trim(outfname)//'.out' !05sep15
    outfname11= 'f11_hD_'//trim(outfname)//'.out' !05sep15

IF(ID==0) THEN !11mar18
    open (outfile1, file=outfname1)

    write(outfile1,*) '------------------------------------'
    write(outfile1,*) 'PARTDEF MODEL  ', 'experiment ', outfname
    write(outfile1,*) '------------------------------------'
END IF

    read (infile, *)nlines

    rewind(infile)
    do ilines =1,nlines
       read (infile, '(1a70)')  charline
	IF(ID==0)        write(outfile1,*)charline    !10jan18
    end do
    rewind(infile)


    !Read info for grids and creates vectors
    call read_grids

    !Read info for economic parameters
    call read_ecpars

    !Approx Markov process !21nov17

    !Input/output controls
    read (infile, *)
    read (infile, *) finiteec
    read (infile, *) niter_finiteec
    read (infile, *) niter_nofiniteec
    read (infile, *) barg_option
    read (infile, *) readq, writeq
    read (infile, *) readv, writev
    read (infile, *) readh, writeh
    read (infile, *) readBandD, writeBandD
    read (infile, *) finiteecND
    read (infile, *) readvND, writevND
    read (infile, *) readBND, writeBND
    read (infile, *) readD01, writeD01
    read (infile, *) nobuybacks

    ! calibration
    read (infile, *)
    read (infile, *) calibrcase

    !Accuracies
    read (infile, *)
    read (infile, *) speed_adjv
    read (infile, *) speed_adjH !05feb14
    read (infile, *) speed_adjq
    read (infile, *) speed_adjBD !22jul14
    read (infile, *) vtol
    read (infile, *) dectol
    read (infile, *) Htol
    read (infile, *) qtol
    read (infile, *) voldtol !13apr13
    read (infile, *) tolall !24jun17
    read (infile, *) countshift !14aug14
    !Interp controls
    read (infile, *)
    read (infile, *) interp_utt_c
    read (infile, *) interp_vexp_c
    read (infile, *) interp_Hexp
    read (infile, *) interp_qqmap
    read (infile, *) optimproc
    read (infile, *) optimprocND

    read (infile, *) rhobeg_opt    !16feb15
    read (infile, *) rhoend_opt    !16feb15
    read (infile, *) tol0_opt !23feb15
    read (infile, *) h0_opt !23feb15
    read (infile, *) h0_1dim !23feb15
    read (infile, *) tol0_1dim !23feb15

    read (infile, *) use_tol_oldvsnew !17jun15
    read (infile, *) tol_oldvsnew !17jun15
    read (infile, *) useD01old

    read (infile, *)            !17feb15
    read (infile, *) draw_valD
    read (infile, *) ja_valD
    read (infile, *) jz_valD
    read (infile, *) jy_valD
    read (infile, *) b_valD
    read (infile, *) d_valD
    read (infile, *) draw_valND
    read (infile, *) ja_valND
    read (infile, *) jz_valND
    read (infile, *) jy_valND
    read (infile, *) draw_3period !03mar16
    if(draw_3period.eq.1) then !03mar16
    write(defout,*) '********************************'
    write(defout,*) 'you have chosen 3period model'
    write(defout,*) 'you have to set finiteec 5 and '
    write(defout,*) 'and niter_finiteec 1 or 2 for T-1 or T-2 outcomes'
    write(defout,*) 'also choose ja_valD for current state ja '
    write(defout,*) '********************************'
    pause
    end if

    read (infile, *) dowelf !25oct21
    read (infile, *) doEVENT !21jun17
    read (infile, *) lengthevent
    read (infile, *) maxlengthevent
    read (infile, *) doIRF !05mar16
    read (infile, *) dropjz_IRF
    read (infile, *) ntimeIRF, npathsIRF
    read (infile, *) do_counterfact

    if(doIRF.eq.1) then !03mar16
    write(defout,*) '********************************'
    write(defout,*) 'you have chosen to run impulse-responses'
    write(defout,*) 'Have to choose:  jz_aver '
    write(defout,*) 'Maybe also change from atarget=a_aver2'
    write(defout,*) 'For z shock: Have to specify jzpath(1), jzpath(2), ... '
    write(defout,*) 'For eps shock: Have to specify epspath(1) '
    write(defout,*) 'Also the write choices into write(42,) depending on shock '
    write(defout,*) '********************************'
    pause
    end if

    read (infile, *) simulsize !18feb17



    close (infile)


  end subroutine readinfo

  !********************************************************************

  SUBROUTINE read_grids
    implicit none

    read (infile, *)
    read (infile, *)
    read (infile, *)

    ! .. state position A .. !04oct12
    read (infile, *) nA
    read (infile, *) gridA_dist
    read (infile, *) Amin
    allocate (Aj(nA))
    Aj(1)= Amin
    do ja=1,nA-1
        Aj(ja+1)=Aj(ja) + gridA_dist
    end do

    ! .. bonds B ..
    read (infile, *) nB
    read (infile, *) gridB_dist
    read (infile, *) Bmin
    !read (infile, *) Bmax
    epshalf=gridB_dist/two
    allocate (Bj(nB))
    Bj(1)= Bmin
    do jb=1,nB-1
        Bj(jb+1)=Bj(jb) + gridB_dist
    end do

    allocate (zeros(nB))
    zeros=zero
    ishit=maxloc(Bj(:), (Bj(:) .lt. zeros(:)-epshalf))
    nBneg=ishit(1)  ! the highest integer where Bi is < 0
    nBzero=nBneg+1  ! the integer where Bi is zero
    if(abs(Bj(nBzero)).gt.closetozero)then
       write(defout,*) 'B(nBzero) is too diff from zero', Bj(nBzero)
       write(outfile1,*) 'Bi(nBzero) is too diff from zero', abs(Bj(nBzero)),closetozero
       stop
    end if
    deallocate(zeros)

!07apr13
    allocate (zeros(nA))
    zeros=zero
    ishit=maxloc(Aj(:), (Aj(:) .lt. zeros(:)-epshalf))
    nAneg=ishit(1)  ! the highest integer where Bi is < 0
    nAzero=nAneg+1  ! the integer where Bi is zero
    if(abs(Aj(1)).lt.closetozero) nAzero=1
    if(abs(Aj(nAzero)).gt.closetozero)then
       write(defout,*) 'A(nAzero) is too diff from zero', Aj(nAzero)
       write(outfile1,*) 'Ai(nAzero) is too diff from zero', abs(Aj(nAzero)),closetozero
       stop
    end if
    if(nAzero.gt.1)then
       write(defout,*) 'A(1) is negative! Sorry it only works for A(1)=0'
       write(outfile1,*) 'A(1) is negative! Sorry it only works for A(1)=0'
       stop
    end if

    deallocate(zeros)

    ! .. defaulted D ..
    read (infile, *) nD
    read (infile, *) gridD_dist
    read (infile, *) Dmin
    !read (infile, *) Dmax
    epshalf=gridD_dist/two
    allocate (Dj(nD))
    Dj(1)= Dmin
    do jd=1,nD-1
        Dj(jd+1)=Dj(jd) + gridD_dist
    end do
    nDzero=1


    ! .. productivity z ..
    read (infile, *) nz
    allocate (zj(nz))
    read (infile, *) zj(1:10) !zj(1:nz)

    ! .. output y ..
    read (infile, *) ny
    read (infile, *) ymin
    read (infile, *) ymax !09feb15
    !ymax=zj(nz)*(one+.01_prec)
    gridy_dist=(ymax-ymin)/(ny-1)
    allocate (yj(ny))
    yj(1)= ymin
    do jy=1,ny-1
        yj(jy+1)=yj(jy) + gridy_dist
    end do

        ! .. Recovery Rbar ..   !16oct14
    read (infile, *) nR
    allocate (Rbar(nR))
    read (infile, *) (Rbar(iR), iR=1,nR) !Rbar(1:nR)


  end SUBROUTINE read_grids


  !********************************************************************
    SUBROUTINE read_ecpars
    use tauchen_mod    !13feb21
    implicit none !02apr18
    read (infile, *)
    read (infile, *) modelfreq
    read (infile, *) delta !24may13
    read (infile, *) sigma
    read (infile, *) beta
    read (infile, *) q0
    q0=one/(q0+one) ! Interest rate
    read (infile, *) transcost !01jun17
    m_stochdisc=(one/q0)*(one/((one/q0)+transcost))
    read (infile, *) gamma_psi  ! Penalty parameter
    read (infile, *) upperdef !07jun13
    read (infile, *) Psimin !22jun13
    read (infile, *) gamma_psi_A  !07jun15
    read (infile, *) Psimin_A !07jun15
    read (infile, *) target_Psimin_A !07jun15
    allocate (psi0(nz)) !10apr13
    read (infile, *) (psi0(jz), jz=1,nz) !10apr13
    read (infile, *) jzstar !01aug13
    read (infile, *) phi1
    allocate (piz(nz,nz))
    allocate (piR(nR))    !16oct14
    do jz=1,10 !nz
       read (infile, *) (piz(jz,jzpr), jzpr=1,10)  !transition
    end do
!13feb21
    read (infile, *) rhoz
    read (infile, *) sdeta
    call tauchen(zero, sdeta, rhoz, 3.0_prec, nz, zj, piz)
    zj(1:nz)=exp(zj(1:nz))/two

    read (infile, *) (piR(iR), iR=1,nR) !piR(1:nR)  !16oct14
    Rbar_aver=sum(Rbar(1:nR)*piR(1:nR))/real(nR) !16oct14
    read (infile, *) noise_epsV  !01feb15
    read (infile, *) noise_epsH
    read (infile, *) noise_epsQ
    read (infile, *) avereps
    read (infile, *) sdeps
    read (infile, *) integGH !29mar15
    read (infile, *)lowereps
    read (infile, *) uppereps
    read (infile, *) nodes_eps
    read (infile, *) minimaldef !29may15
    read (infile, *) varphi !01may15
    read (infile, *) barc !01may15
    read (infile, *) mu !23dec13
    read (infile, *) chiB
    read (infile, *) sd_B
    read (infile, *) chiL
    read (infile, *) sd_L

    end SUBROUTINE read_ecpars

!*************************************************************
! ALLOCATE GLOBAL ARRAYS
!*************************************************************
    subroutine allocstuff
    implicit none !02apr18

   allocate ( uttarray(1:nB,1:nD))
   allocate ( vexpD(1:nB,1:nD,1:nz,1:nA) )
   allocate ( vD(1:ny,1:nA,1:nz), v(1:ny,1:nA,1:nz) )
   allocate ( locDD(1:ny,1:nA,1:nz),locBD(1:ny,1:nA,1:nz) )
   allocate ( vDold(1:ny,1:nA,1:nz) )
   allocate ( locDDold(1:ny,1:nA,1:nz),locBDold(1:ny,1:nA,1:nz) )
   allocate ( qqtil(nAzero:nA,1:nD,1:nz) ) !29jun14 !07apr13
   allocate ( qqtil_temp(nAzero:nA,1:nD,1:nz)  ) !29jun14 !25mar13
   allocate ( H(1:ny,1:nA,1:nz),Hold(1:ny,1:nA,1:nz))
   allocate ( HD(1:ny,1:nA,1:nz),HDold(1:ny,1:nA,1:nz),HND(1:ny,1:nA,1:nz),HNDold(1:ny,1:nA,1:nz) ) !05sep15
   allocate ( delta_HDexp(1:ny,1:nA,1:nz),delta_HNDexp(1:ny,1:nA,1:nz) ) !05sep15
   allocate ( HexpR(1:ny,1:nA,1:nz) )   !23dec13
   allocate ( qq(1:nB,1:nD,1:nA,1:nz) ) !30nov15
   allocate (v2d(ny,nA,nz), H2d(ny,nA,nz),qtil2d(nAzero:nA,1:nD,1:nz)) !26jun14
   allocate (q2d(1:nB,nD)) !30nov15
   allocate ( DD_c(1:ny,1:nA,1:nz), BD_c(1:ny,1:nA,1:nz),DD_cold(1:ny,1:nA,1:nz), BD_cold(1:ny,1:nA,1:nz) )
   allocate ( vexpD_array(1:nB,1:nD,1:nA,1:nz), uttD_array(1:nB,1:nD) )

   allocate ( vexpND_array(1:nB,1:nA,1:nz), uttND_array(1:nB) ) !03feb15
   allocate ( locBND(1:ny,1:nA,1:nz), locBNDold(1:ny,1:nA,1:nz) ) !03feb15
   allocate ( BND_c(1:ny,1:nA,1:nz), BND_cold(1:ny,1:nA,1:nz) ) !03feb15
   allocate ( vND(1:ny,1:nA,1:nz),vNDold(1:ny,1:nA,1:nz) ) !03feb15
   allocate ( D01(1:ny,1:nA,1:nz), D01old(1:ny,1:nA,1:nz) ) !04feb15
   allocate ( B_c(1:ny,1:nA,1:nz), D_c(1:ny,1:nA,1:nz) ) !04feb15

    end subroutine allocstuff


  !********************************************************************
  !initstuff
  !********************************************************************
  subroutine  initstuff
  implicit none !02apr18


    qq=q0/(one-q0*delta)

    if(readq .eq. 1)then
       call read_q
    else
       qqtil=q0/(one-q0*delta) !29jun14 q0
    endif
    !26mar14 call qqmap   !24feb14

    if(readv .eq. 1)then
       call read_vD
    else
       vD=-100.00_prec
    endif

     if(readBandD .eq. 1)then !13apr13
       call read_BD
       call read_DD
    else
        locBD=1
        locDD=1
    endif


    if(readh .eq. 1)then !16sep12
       call read_h !05sep15
       call read_hD !05sep15
       call read_hND !05sep15
    else
       H=one
    endif



    if(readvND .eq. 1)then
       call read_vND
    else
       vND=-100.00_prec
    endif
     if(readBND .eq. 1)then !13apr13
       call read_BND
    else
        locBND=1
    endif

    if(readD01 .eq. 1)then
       call read_D01
    else
       D01=1
       D01(:,nAzero,:)=0
    endif

    if(finiteec .eq. 5) call init_finiteec5 !02sep15

! New:
!    qqtil_temp=qqtil
!    vDold=VD
!    Hold=H
!    delta_HDexp=zero
!    delta_HNDexp=zero
!    HDold=zero
!    HNDold=zero
!    vexpD_array=zero
!    vexpND_array=zero
!    uttD_array=zero
!    uttND_array=zero
!    vNDold=zero
!    locBNDold=locBND
!    D01old=1
!    B_c=zero
!    D_c=one
!
!    locBDold=locBD
!    locDDold=locDD
!    locBNDold=locBND
!    BD_cold=BD_c
!    DD_cold=DD_c
!    BND_cold=BND_c
!
!    bbddl=zero
!    bbddu=zero
!    q2d(:,:)=zero
!    v2d(:,:,:)=zero
!    H2d(:,:,:)=zero
!    qtil2d(:,:,:)=zero


  end subroutine initstuff



! ************************************************
! Initialiase final values for finiteeec=3 and 4
! ************************************************
!02sep15
 subroutine init_finiteec5
 implicit none

    H=zero
    HD=zero !05sep15
    HND=one !05sep15
   do jy=1, ny
     do ja=1, nA
      do jz=1, nz
        vD(jy,ja,jz)= utt(yj(jy))
        vND(jy,ja,jz)=vD(jy,ja,jz)-10.0_prec
      end do
     end do
    end do

    D01=1

! .. These are just ..
    BD_c=zero
    DD_c=one
    BND_c=zero


 end subroutine init_finiteec5



  !
  !********************************************************************
  ! [2.] READ/WRITE INITIAL CONDITIONS
  !********************************************************************
  !
  subroutine read_q
  implicit none !02apr18
  open (outfile2, file=outfname2)
    do ja=nAzero,nA !25oct15 nAzero+1 !07apr13
     do jd = 1, nD
      do jz=1, nz
        read(outfile2,*) qqtil(ja,jd,jz)
      end do
     end do
    end do
  close(outfile2)
  end subroutine read_q

  subroutine write_q
  implicit none !02apr18
  open (outfile2, file=outfname2)
    do ja=nAzero,nA  !25oct15 nAzero+1 !07apr13
     do jd = 1, nD
      do jz=1, nz
        write(outfile2,*) qqtil(ja,jd,jz)
      end do
     end do
    end do
  close(outfile2)
  end subroutine write_q

  subroutine read_vD
  implicit none !02apr18
  open (outfile3, file=outfname3)
    do jy=1,ny
     do ja = 1, nA
      do jz=1, nz
        read(outfile3,*) vD(jy,ja,jz)
      end do
     end do
    end do
  close(outfile3)
  end subroutine read_vD

  subroutine write_vD
  implicit none !02apr18
  open (outfile3, file=outfname3)
    do jy=1,ny
     do ja = 1, nA
      do jz=1, nz
        write(outfile3,*) vD(jy,ja,jz)
      end do
     end do
    end do
  close(outfile3)
  end subroutine write_vD

!16sep12 H(1:ny,1:nA,1:nz)
  subroutine read_h
  implicit none !02apr18
  open (outfile4, file=outfname4)
    do jy=1,ny
     do ja = 1, nA
      do jz=1, nz
        read(outfile4,*) H(jy,ja,jz)
      end do
     end do
    end do
  close(outfile4)
  end subroutine read_h
  subroutine write_h
  implicit none !02apr18
  open (outfile4, file=outfname4)
    do jy=1,ny
     do ja = 1, nA
      do jz=1, nz
        write(outfile4,*) H(jy,ja,jz)
      end do
     end do
    end do
  close(outfile4)
  end subroutine write_h

  subroutine read_hND
  implicit none !02apr18
  open (outfile10, file=outfname10)
    do jy=1,ny
     do ja = 1, nA
      do jz=1, nz
        read(outfile10,*) HND(jy,ja,jz)
      end do
     end do
    end do
  close(outfile10)
  end subroutine read_hND
  subroutine write_hND
  implicit none !02apr18
  open (outfile10, file=outfname10)
    do jy=1,ny
     do ja = 1, nA
      do jz=1, nz
        write(outfile10,*) HND(jy,ja,jz)
      end do
     end do
    end do
  close(outfile10)
  end subroutine write_hND

  subroutine read_hD
  implicit none !02apr18
  open (outfile11, file=outfname11)
    do jy=1,ny
     do ja = 1, nA
      do jz=1, nz
        read(outfile11,*) HD(jy,ja,jz)
      end do
     end do
    end do
  close(outfile11)
  end subroutine read_hD
  subroutine write_hD
  implicit none !02apr18
  open (outfile11, file=outfname11)
    do jy=1,ny
     do ja = 1, nA
      do jz=1, nz
        write(outfile11,*) HD(jy,ja,jz)
      end do
     end do
    end do
  close(outfile11)
  end subroutine write_hD

!13apr13
  subroutine read_BD
  implicit none !02apr18
  open (outfile5, file=outfname5)
    do jy=1,ny
     do ja = 1, nA
      do jz=1, nz
        read(outfile5,*) BD_c(jy,ja,jz) !17aug14 locBD(jy,ja,jz)
      end do
     end do
    end do
  close(outfile5)
  end subroutine read_BD
  subroutine write_BD
  implicit none !02apr18
  open (outfile5, file=outfname5)
    do jy=1,ny
     do ja = 1, nA
      do jz=1, nz
        write(outfile5,*) BD_c(jy,ja,jz) !17aug14 locB(jy,ja,jz)
      end do
     end do
    end do
  close(outfile5)
  end subroutine write_BD

  subroutine read_DD
  implicit none !02apr18
  open (outfile6, file=outfname6)
    do jy=1,ny
     do ja = 1, nA
      do jz=1, nz
        read(outfile6,*) DD_c(jy,ja,jz) !17aug14 locD(jy,ja,jz)
      end do
     end do
    end do
  close(outfile6)
  end subroutine read_DD
  subroutine write_DD
  implicit none !02apr18
  open (outfile6, file=outfname6)
    do jy=1,ny
     do ja = 1, nA
      do jz=1, nz
        write(outfile6,*) DD_c(jy,ja,jz) !17aug14 locD(jy,ja,jz)
      end do
     end do
    end do
  close(outfile6)
  end subroutine write_DD


!03jan15
  subroutine read_vND
  implicit none !02apr18
  open (outfile7, file=outfname7)
    do jy=1,ny
     do ja = 1, nA
      do jz=1, nz
        read(outfile7,*) vND(jy,ja,jz)
      end do
     end do
    end do
  close(outfile7)
  end subroutine read_vND
  subroutine write_vND
  implicit none !02apr18
  open (outfile7, file=outfname7)
    do jy=1,ny
     do ja = 1, nA
      do jz=1, nz
        write(outfile7,*) vND(jy,ja,jz)
      end do
     end do
    end do
  close(outfile7)
  end subroutine write_vND
  subroutine read_BND
  implicit none !02apr18
  open (outfile8, file=outfname8)
    do jy=1,ny
     do ja = 1, nA
      do jz=1, nz
        read(outfile8,*) BND_c(jy,ja,jz)
      end do
     end do
    end do
  close(outfile8)
  end subroutine read_BND
  subroutine write_BND
  implicit none !02apr18
  open (outfile8, file=outfname8)
    do jy=1,ny
     do ja = 1, nA
      do jz=1, nz
        write(outfile8,*) BND_c(jy,ja,jz)
      end do
     end do
    end do
  close(outfile8)
  end subroutine write_BND
  subroutine read_D01
  implicit none !02apr18
  open (outfile9, file=outfname9)
    do jy=1,ny
     do ja = 1, nA
      do jz=1, nz
        read(outfile9,*) D01(jy,ja,jz)
      end do
     end do
    end do
  close(outfile9)
  end subroutine read_D01
  subroutine write_D01
  implicit none !02apr18
  open (outfile9, file=outfname9)
    do jy=1,ny
     do ja = 1, nA
      do jz=1, nz
        write(outfile9,*) D01(jy,ja,jz)
      end do
     end do
    end do
  close(outfile9)
  end subroutine write_D01


! *********************************************************
 subroutine stat_distr !15jun17
    implicit none
    integer :: time, j
    real(prec), dimension(:), allocatable:: distr(:)
    allocate(distr(nz))

    distr=one/real(nz)
    do time=1, 2000
    distr=matmul(transpose(piz),distr)
    end do

  write(outfile1,*)
  write(outfile1,'(a30)') 'Stationary distribution '
     write(outfile1,'(15f9.6)') (distr(j), j=1, nz)
   open(297, file='stat_distr.dat')
     write(297,'(15f9.6)') (distr(j), j=1, nz)
     write(297,'(15f9.6)') (zj(j), j=1, nz)
   close(297)

  zaver_glob=sum(zj(:)*distr(:))
  write(outfile1,*)
  write(outfile1,'(a10,f7.4)') 'Mean z ', zaver_glob

 end subroutine stat_distr


!*************************************************************
! [3.] DOMESTIC AGENT GIVEN CONTINUATION
!*************************************************************
 function utt_c(bbb,ddd) !26jun14
  use interp
  implicit none
  real(prec) :: bbb,  ddd, utt_c
  real(prec) :: qa

    real(prec) :: bbbb
    real(prec), dimension(nD) :: temp

 if( &
    &   (ddd.gt.(one))   &
    & .or.(ddd.lt.zero)   &
    & .or.(bbb.lt.Bj(1))   &
    & .or.(bbb.gt.Bj(nB))   &
    & .or. ((bbb+(one-delta)*Rbar(nR)*ddd*Aj(ja)+max(delta*Aj(ja),zero)).lt.Aj(1)-small) &  !01jun15  !16oct14
    & .or. ((bbb+(one-delta)*Rbar(1)*ddd*Aj(ja)+max(delta*Aj(ja),zero)).gt.Aj(nA)) &   !16oct14
    & .or.((bbb.lt.zero) .and.(ddd.gt.zero))    & !02dec15: comment out
    & .or.((Aj(ja).le.zero).and.(ddd.gt.zero))  &
    &         ) then
        utt_c=-huge
 else


    if(bbb.lt.Bj(nBzero)) then
     if(nobuybacks.eq.1) then
        qa=q0/(one-q0*delta)
     else if(nobuybacks.eq.0) then !01dec15 !30nov15
        qa= blip(Bj(1:nB),Dj,qq(1:nB,:,ja,jz),bbb,ddd)
     end if
    end if

    if(bbb.ge.Bj(nBzero)) then !(interpolated prices) !29jun14 !01dec15
    ! .. options interpolation ..
        if(interp_utt_c.eq.1) then
        qa= blip(Bj(1:nB),Dj,qq(1:nB,:,ja,jz),bbb,ddd) !30nov15
        else
            write(*,*) 'no interp option! '
            stop
        end if
    ! .. end interpolation ..
    end if
        utt_c=utt(yj(jy)- (Aj(ja) - ddd*Aj(ja) )+ qa*bbb )
 end if

 end function utt_c


!*************************************************************
  function vexpD_c(bbb,ddd)   !26jun14
  use interp
  implicit none
  real(prec) :: bbb,  ddd, vexpD_c, aapr
  integer :: jjzpr
  real(prec) :: limits_eps(2)

  limits_eps(1)=lowereps
  limits_eps(2)=uppereps

 if( &
    &     (ddd.gt.(one))   &
    & .or.(ddd+.0000001_prec.lt.zero)   & !06feb15
    & .or.(ddd.lt.minimaldef)   & !06feb15
    & .or.(bbb.lt.Bj(1))   &
    & .or.(bbb.gt.Bj(nB))   &
    & .or. ((bbb+(one-delta)*Rbar(nR)*ddd*Aj(ja)+max(delta*Aj(ja),zero)).lt.Aj(1)-small) & !01jun15   !16oct14
    & .or. ((bbb+(one-delta)*Rbar(1)*ddd*Aj(ja)+max(delta*Aj(ja),zero)).gt.Aj(nA)) &   !16oct14
    & .or.((bbb.lt.zero) .and.(ddd.gt.zero))    & !02dec15: should comment out
    & .or.((Aj(ja).le.zero).and.(ddd.gt.zero))  &
!    & .or. (bbb.gt.zero) &    !13jun17
    &         ) then
        vexpD_c=-huge

 else ! .. if we are inside grids ..

   vexpD_c=zero
 do iR=1, nR !16oct14
   aapr=bbb+(one-delta)*Rbar(iR)*ddd*Aj(ja)+max(delta*Aj(ja),zero)   !16oct14
   do jjzpr=1, nz

    if(noise_epsV.eq.0) then
        vexpD_c=vexpD_c+piR(iR)*piz(jz,jjzpr)*vdF(zero)
    else if(noise_epsV.eq.1) then
        write(*,*) 'noise !! '
        stop
    end if

   end do
  end do !16oct14
 end if !within grids


 contains

 function vdF(epspr) !01feb15
 implicit none !02apr18
 real(prec) :: vdF, epspr, yypr
 real(prec) :: vtemp_ND, vtemp_D
 integer :: jyprlow, jyprup,japrlow, japrup !04feb15
    yypr=(zj(jjzpr)+epspr)*psi(ddd,jjzpr,aapr) !07jun15
    yypr=max(yj(1), yypr)
    yypr=min(yj(ny), yypr)
    aapr=max(Aj(1), aapr)
    aapr=min(Aj(na), aapr)

    ! .. locate box containing (yypr, aapr)
    jyprlow=count(yj.le.yypr)
    jyprup=min(jyprlow+1,ny)
    japrlow=count(Aj.le.aapr)
    japrup=min(japrlow+1,nA)

 if(D01(jyprup,japrlow,jjzpr).eq.1) then   !default         !04feb15

    if(interp_vexp_c.eq.1) then
    ! .. bilinear ..
    vdF=blip(yj,Aj,vD(:,:,jjzpr),yypr,aapr)
    else
        write(*,*) 'bad interp vexp !! '
        stop
    end if

 else if (D01(jyprlow,japrup,jjzpr).eq.0) then       !no-default

    ! .. bilinear ..
    vdF=blip(yj,Aj,vND(:,:,jjzpr),yypr,aapr)

 else
   if(interp_vexp_c.eq.1) then
    ! .. bilinear ..
    vtemp_ND=blip(yj,Aj,vND(:,:,jjzpr),yypr,aapr)
    vtemp_D =blip(yj,Aj, vD(:,:,jjzpr),yypr,aapr)
   else
        write(*,*) 'bad interp vexp !! '
        stop
   end if

    if ( vtemp_ND.ge.vtemp_D) then
      vdF=vtemp_ND
    else
      vdF=vtemp_D
    end if

 end if

 end function vdF

 end function vexpD_c

!*************************************************************
  function vv_c(bbb,ddd)
   implicit none
   real(prec) :: bbb, ddd, vv_c
   vv_c=utt_c(bbb,ddd)+beta*vexpD_c(bbb,ddd)

  end function vv_c

  function negat_vv_c(bbdddum,nargum)
   implicit none
   integer :: nargum
   real(prec), dimension(nargum) :: bbdddum
   real(prec) :: negat_vv_c, bb, dd
   bb= (bbddu(1)-bbddl(1))*bbdddum(1)+bbddl(1) !04sep15
   dd= (bbddu(2)-bbddl(2))*bbdddum(2)+bbddl(2) !04sep15
   negat_vv_c=-vv_c(bb,dd)
  end function negat_vv_c

  function negat_vv_c_comp(nargum,bbdd)
   implicit none
   integer :: nargum
   real(prec), dimension(nargum) :: bbdd
   real(prec) :: negat_vv_c_comp
   negat_vv_c_comp=-vv_c(bbdd(1),bbdd(2))
  end function negat_vv_c_comp


  subroutine vexpD_array_defi
   implicit none
      do ja=1,na
       do jz=1,nz
   do jb=1, nB
    do jd=1, nD
     vexpD_array(jb,jd,ja,jz)=vexpD_c(Bj(jb),Dj(jd))
    end do
   end do
    end do
    end do
  end subroutine vexpD_array_defi

  subroutine uttD_array_defi
   implicit none
   do jb=1, nB
    do jd=1, nD
     uttD_array(jb,jd)=utt_c(Bj(jb),Dj(jd))
    end do
   end do
  end subroutine uttD_array_defi
!*************************************************************

 subroutine mappings_mpi !mpi
    implicit none !02apr18
    integer :: j_mpi
    n_mpi=ny*na*nz
    allocate( jy_mpi(n_mpi), &
    &         ja_mpi(n_mpi), &
    &         jz_mpi(n_mpi) )
     do jy=1,ny
      do ja=1,na
       do jz=1, nz
             j_mpi= na*nz*(jy-1) &
              &  +     nz*(ja-1) &
              &  +        (jz-1) &
              &  +         1
            jy_mpi(j_mpi)=jy
            ja_mpi(j_mpi)=ja
            jz_mpi(j_mpi)=jz
       end do
      end do
     end do
 end subroutine mappings_mpi

!*************************************************************
  subroutine mpiagentD_opt  !mpi
  use interp
  implicit none
  integer, dimension(2)::ishit2
  real(prec) :: praxis
  integer :: prin
  integer :: it
  real(prec), dimension(2) :: bbdd
  real(prec), dimension(2) :: bbdddum !15feb15
  real(prec), dimension(2) ::  bbddduml, bbdddumu  !15feb15
  real(prec), dimension(:), allocatable ::  v_temp(:,:,:) !22jul14

   external praxis


! -----open mpi------------ !mpi
    integer :: n_top, n_end, n0,  j_mpi
    real(prec),dimension(:),allocatable:: vtemp_mpi(:), vtemp_mpii(:)
    real(prec),dimension(:),allocatable:: BDc_mpi(:), DDc_mpi(:)
    real(prec),dimension(:),allocatable:: BDc_mpii(:), DDc_mpii(:)
!08oct20     real(prec), dimension(:), allocatable :: &
!08oct20     & errBD_temp(:), errDD_temp(:), errmaxBD_temp(:), errmaxDD_temp(:) !03jun20
    ! .. mpi - allocate to processors ..
	!determines number of integer assigned to each node
	do n0=1,n_mpi
		if (n0*nproc>=n_mpi) exit
	end do
    allocate( vtemp_mpi(n0), &
     & BDc_mpi(n0),DDc_mpi(n0))
    allocate( vtemp_mpii(n0*nproc), &
     & BDc_mpii(n0*nproc),DDc_mpii(n0*nproc))
	! .. compute Ntop and Nend for each processor id ..
	n_top=id*n0+1
	n_end=min((id+1)*n0,n_mpi) !notice n0*nproc might be above n

!!**     allocate(errBD_temp(0:nproc-1), errDD_temp(0:nproc-1), &
!!**         & errmaxBD_temp(0:nproc-1), errmaxDD_temp(0:nproc-1)) !03jun20
! ------- close mpi -----------


   allocate ( v_temp(1:ny,1:nA,1:nz) ) !22jul14


IF(ID==0) then !10jan18
    if(draw_valD.eq.1) then !17feb15

    ! .. Draw figure of value as a function of D (for secific ja, jz, jy) ..
    open(297, file='valueD_fig.dat')
    !do ja=26,26
      ja=ja_valD
      write(297,'(a6,i4,a6,i4,a6,i4,a6,f14.10,a6,f14.10)') &
        & 'ja=',ja_valD, 'jz=',jz_valD, 'jy=', jy_valD, 'b=', b_valD, 'd=',  d_valD !10jan17
      write(297,'(a,a9,a14)') 'ja', 'D', 'val'
           jz=jz_valD !8
           jy=jy_valD !1
        if(interp_utt_c.eq.2) then
            call splie2(Bj(1:nB),Dj,qq(1:nB,:,ja,jz),q2d)  !29jun14 !01dec15
        end if
           bbdd(2)= minimaldef !10jan17 zero
           bbdd(1)= b_valD !0.005_prec !Bj(nB)
           do while(bbdd(2).le.1.00)
    if(interp_utt_c.eq.1) then
             write(297,'(i3,f9.4,f14.6)') ja, bbdd(2), vv_c(bbdd(1),bbdd(2))
    else if(interp_utt_c.eq.2) then
             write(297,'(i3,f9.4,f14.6)') ja, bbdd(2), vv_c(bbdd(1),bbdd(2))
    end if

             bbdd(2)=bbdd(2)+ .01 !0.001 !0.0005
           end do
      !end do
      close(297)
    end if


    ! .. Draw figure of value as a function of B (for secific ja, jz, jy) ..
    open(297, file='valueB_fig.dat')
    !do ja=26,26
      ja=ja_valD
      write(297,'(a6,i4,a6,i4,a6,i4,a6,f14.10,a6,f14.10)') &
        & 'ja=',ja_valD, 'jz=',jz_valD, 'jy=', jy_valD, 'b=', b_valD, 'd=',  d_valD !10jan17
      write(297,'(a,a9,a14)') 'ja', 'B', 'val'
           jz=jz_valD
           jy=jy_valD
           bbdd(2)= d_valD
           bbdd(1)= zero
           do while(bbdd(1).lt.Bj(nB))
             write(297,'(i3,f9.4,f14.6)') ja, bbdd(1), vv_c(bbdd(1),bbdd(2))
             bbdd(1)=bbdd(1)+0.0005 !0.0005
           end do
    !end do
      close(297)


    open(297, file='BellRHS_fig.dat')
    write(297,'(3a3,x,a14,a14,a14,a9,a9,a9,a9,a9,a9)') 'ja','jz','jy',    &
           &   'vD ', 'vDold ', &
           &   'abs(vD- vDold)', &
           &   'BD ', 'BDold ', &
           &   'DD ', 'DDold ', &
           &   'abs(BD -BDold)', &
           &   'abs(DD-DDold)'
END IF

        ! .. nominal loan size ..


        ! .. build spline v in vexp_c(if spline used)..
        if(interp_vexp_c.eq.2) then
         do jzpr=1, nz
          call splie2(yj,Aj,vD(:,:,jzpr),v2d(:,:,jzpr))
         end do
        end if
        if(interp_vexp_c.eq.3) then
         do jzpr=1, nz
          call splie2_lip_spl(yj,Aj,vD(:,:,jzpr),v2d(:,:,jzpr))
         end do
        end if

    ! .. STEP 1 (prelim) ..
    errBD=zero !11aug14
    errDD=zero
    errmaxBD = zero
    errmaxDD = zero
    !03jun20 errBND=zero
!08oct20    errBD_temp(:)=zero      !03jun20
!08oct20    errDD_temp(:)=zero
!08oct20    errmaxBD_temp(:) = zero
!08oct20    errmaxDD_temp(:) = zero !03jun20


    !  ************ MAIN LOOP ************************

! -----open mpi------------ !mpi !02mar16
    do j_mpi= n_top, n_end
            ja=ja_mpi(j_mpi)
            jz=jz_mpi(j_mpi)
            jy=jy_mpi(j_mpi)
! -----close mpi------------


! .. STEP 1:initialise on the grid using maxloc ..

! .. STEP 2: optimise off the grid by interpolating  ..

    prin = 0

    if((optimproc.eq.21)) then
     bbdd(1) = BD_cold(jy,ja,jz) !02feb15
     bbdd(2) = DD_cold(jy,ja,jz)
    end if

    if((optimproc.eq.121).or.(optimproc.eq.21)) then

    ! .. normalisation ..
    bbddl(1) = Bj(1)
    bbddu(1) = Bj(nB)
    bbddu(2) = Dj(nD)
    bbddl(2) =  minimaldef
    bbdddum(1)=(bbdd(1)-bbddl(1))/(bbddu(1)-bbddl(1))
    bbdddum(2)=(bbdd(2)-bbddl(2))/(bbddu(2)-bbddl(2))


        if(ja.eq.nAzero) then !18feb15
            bbdd(1)= zero !18feb15
            !bbdd(2)= zero !18feb15
            bbdd(2)= minimaldef !29may15   .0001_prec !06feb15
            v_temp(jy,ja,jz)= vv_c(bbdd(1),bbdd(2))
        else
            !04sep15 v_temp(jy,ja,jz)= -praxis( tol0_opt, h0_opt, 2, prin, bbdd, negat_vv_c ) !29jul14
            v_temp(jy,ja,jz)= -praxis( tol0_opt, h0_opt, 2, prin, bbdddum, negat_vv_c ) !04sep15
            bbdd(1)= (bbddu(1)-bbddl(1))*bbdddum(1)+bbddl(1) !04sep15
            bbdd(2)= (bbddu(2)-bbddl(2))*bbdddum(2)+bbddl(2) !04sep15
        end if
    end if

    ! .. new policy off grid ..

     BD_c(jy,ja,jz)=bbdd(1)
     DD_c(jy,ja,jz)=bbdd(2)


    ! .. compare outcomes across iterations ..
IF(ID==0) then  !10jan18
    write(297,'(3i3,x,f14.4,f14.4,f14.4,f9.4,f9.4,f9.4,f9.4,f9.4,f9.4,f9.4)') ja,jz,jy,    &
           &   v_temp(jy,ja,jz), vDold(jy,ja,jz), & !29jul14
           &   abs(v_temp(jy,ja,jz)- vDold(jy,ja,jz)), &
           &   BD_c(jy,ja,jz), BD_cold(jy,ja,jz), &
           &   DD_c(jy,ja,jz), DD_cold(jy,ja,jz), &
           &   abs(BD_c(jy,ja,jz)-BD_cold(jy,ja,jz)), &
           &   abs(DD_c(jy,ja,jz)-DD_cold(jy,ja,jz)), &
           &   delta*Aj(ja)+BD_c(jy,ja,jz)+(one-delta)*Rbar(1)*DD_c(jy,ja,jz)*Aj(ja)
END IF


!08oct20     errmaxBD_temp(id)=max(errmaxBD_temp(id),abs(BD_c(jy,ja,jz)-BD_cold(jy,ja,jz))) !03jun20
!08oct20     errBD_temp(id)=errBD_temp(id)+abs(BD_c(jy,ja,jz)-BD_cold(jy,ja,jz))
!08oct20     errmaxDD_temp(id)=max(errmaxDD_temp(id),abs(DD_c(jy,ja,jz)-DD_cold(jy,ja,jz)))
!08oct20     errDD_temp(id)=errDD_temp(id)+abs(DD_c(jy,ja,jz)-DD_cold(jy,ja,jz))            !03jun20

!08oct20
!08oct20         BD_c(jy,ja,jz)=bbdd(1)
!08oct20         DD_c(jy,ja,jz)=bbdd(2)
!08oct20        v_temp(jy,ja,jz)= vv_c(BD_c(jy,ja,jz),DD_c(jy,ja,jz))

!08oct20    ! .. locate on grid ..
!08oct20            locBD(jy,ja,jz) = count(Bj.le.bbdd(1))
!08oct20            if(       abs(Bj(locBD(jy,ja,jz))-bbdd(1)) &
!08oct20                & .gt.abs(Bj(min(locBD(jy,ja,jz)+1,nB))-bbdd(1))) &
!08oct20                & locBD(jy,ja,jz) = min(locBD(jy,ja,jz)+1,nB)
!08oct20            locDD(jy,ja,jz) = count(Dj.le.bbdd(2))
!08oct20            if(       abs(Dj(locDD(jy,ja,jz))-bbdd(2)) &
!08oct20                & .gt.abs(Dj(min(locDD(jy,ja,jz)+1,nD))-bbdd(2))) &
!08oct20                & locDD(jy,ja,jz) = min(locDD(jy,ja,jz)+1,nD)



    !  ************ END MAIN LOOP ************************

! -----open mpi------------ !mpi
            vtemp_mpi(j_mpi-n_top+1)=v_temp(jy,ja,jz)
            BDc_mpi(j_mpi-n_top+1)=BD_c(jy,ja,jz)
            DDc_mpi(j_mpi-n_top+1)=DD_c(jy,ja,jz)
    end do !i_mpi

 call MPI_BARRIER(MPI_COMM_WORLD,IERROR)

 call MPI_ALLGATHER(vtemp_mpi(1), n0, MPI_DOUBLE_PRECISION, &
    	         &  vtemp_mpii(1), n0, MPI_DOUBLE_PRECISION, &
                 &  MPI_COMM_WORLD, ierror)
 call MPI_ALLGATHER(BDc_mpi(1), n0, MPI_DOUBLE_PRECISION, &
    	         &  BDc_mpii(1), n0, MPI_DOUBLE_PRECISION, &
                 &  MPI_COMM_WORLD, ierror)
 call MPI_ALLGATHER(DDc_mpi(1), n0, MPI_DOUBLE_PRECISION, &
    	         &  DDc_mpii(1), n0, MPI_DOUBLE_PRECISION, &
                 &  MPI_COMM_WORLD, ierror)

!!!**call MPI_BARRIER(MPI_COMM_WORLD,IERROR)

    do j_mpi= 1, n_mpi
            v_temp(jy_mpi(j_mpi),ja_mpi(j_mpi),jz_mpi(j_mpi)) &
                    & = vtemp_mpii(j_mpi)
            BD_c(jy_mpi(j_mpi),ja_mpi(j_mpi),jz_mpi(j_mpi)) &
                    & = BDc_mpii(j_mpi)
            DD_c(jy_mpi(j_mpi),ja_mpi(j_mpi),jz_mpi(j_mpi)) &
                    & = DDc_mpii(j_mpi)
    end do !i_mpi
    deallocate(vtemp_mpi,BDc_mpi,DDc_mpi)
    deallocate(vtemp_mpii,BDc_mpii,DDc_mpii)
!  -----close mpi------------

!08oct20     errmaxBD=maxval(errmaxBD_temp(0:nproc-1)) !03jun20
!08oct20     errBD=maxval(errBD_temp(0:nproc-1))
!08oct20     errmaxDD=maxval(errmaxDD_temp(0:nproc-1))
!08oct20     errDD=maxval(errDD_temp(0:nproc-1))       !03jun20


!08oct20
     errmaxBD=maxval(abs(BD_c(:,:,:)-BD_cold(:,:,:)))
     errmaxDD=maxval(abs(DD_c(:,:,:)-DD_cold(:,:,:)))
     errBD=sum(abs(BD_c(:,:,:)-BD_cold(:,:,:)))
     errDD=sum(abs(DD_c(:,:,:)-DD_cold(:,:,:)))
     errBD=errBD/real(ny*nA*nz)
     errDD=errDD/real(ny*nA*nz)


!08oct20
         BD_c(:,:,:)=speed_adjBD*BD_c(:,:,:)+(one-speed_adjBD)*BD_cold(:,:,:)
         DD_c(:,:,:)=speed_adjBD*DD_c(:,:,:)+(one-speed_adjBD)*DD_cold(:,:,:)

        do jz=1, nz
         do ja = 1, nA
          do jy=1, ny
        v_temp(jy,ja,jz)= vv_c(BD_c(jy,ja,jz),DD_c(jy,ja,jz))
    ! .. locate on grid ..
            locBD(jy,ja,jz) = count(Bj.le.BD_c(jy,ja,jz))
            if(       abs(Bj(locBD(jy,ja,jz))-BD_c(jy,ja,jz)) &
                & .gt.abs(Bj(min(locBD(jy,ja,jz)+1,nB))-BD_c(jy,ja,jz))) &
                & locBD(jy,ja,jz) = min(locBD(jy,ja,jz)+1,nB)
            locDD(jy,ja,jz) = count(Dj.le.DD_c(jy,ja,jz))
            if(       abs(Dj(locDD(jy,ja,jz))-DD_c(jy,ja,jz)) &
                & .gt.abs(Dj(min(locDD(jy,ja,jz)+1,nD))-DD_c(jy,ja,jz))) &
                & locDD(jy,ja,jz) = min(locDD(jy,ja,jz)+1,nD)
          end do
         end do
        end do

    vD=v_temp !29jul14

IF(ID==0)   close(297)  !10jan18
      !stop
   deallocate ( v_temp) !22jul14
!08oct20   deallocate(errBD_temp, errDD_temp, &
!08oct20        & errmaxBD_temp, errmaxDD_temp) !03jun20

  end subroutine mpiagentD_opt


!*************************************************************
  function vexpND_c(bbb)   !03feb15
  use interp
  implicit none
  real(prec) :: bbb,  vexpND_c, aapr
  integer :: jjzpr
  real(prec) :: limits_eps(2)

  limits_eps(1)=lowereps
  limits_eps(2)=uppereps


 if( &
    & (bbb.lt.Bj(1))   &
    & .or.(bbb.gt.Bj(nB))   &
    & .or. ((bbb+max(delta*Aj(ja),zero)).lt.Aj(1)-small) & !01jun15
    & .or. ((bbb+max(delta*Aj(ja),zero)).gt.Aj(nA)) &
    &         ) then
        vexpND_c=-huge

 else ! .. if we are inside grids ..

   vexpND_c=zero
   aapr=bbb+max(delta*Aj(ja),zero)
   do jjzpr=1, nz
        vexpND_c=vexpND_c+piz(jz,jjzpr)*vdF(zero)
   end do
 end if !within grids

 contains

 function vdF(epspr) !03feb15
 implicit none !02apr18
 real(prec) :: vdF, epspr, yypr
 real(prec) :: vtemp_ND, vtemp_D
 integer :: jyprlow, jyprup,japrlow, japrup !04feb15

    yypr=(zj(jjzpr)+epspr)  !*psi(zero,jjzpr)
    yypr=max(yj(1), yypr)
    yypr=min(yj(ny), yypr)
    aapr=max(Aj(1), aapr)
    aapr=min(Aj(na), aapr)

    ! .. locate box containing (yypr, aapr)
    jyprlow=count(yj.le.yypr)
    jyprup=min(jyprlow+1,ny)
    japrlow=count(Aj.le.aapr)
    japrup=min(japrlow+1,nA)

 if(D01(jyprup,japrlow,jjzpr).eq.1) then   !default         !04feb15

    if(interp_vexp_c.eq.1) then
     vdF=blip(yj,Aj,vDold(:,:,jjzpr),yypr,aapr) !10feb15: vDold for vD
    else
     write(*,*) 'wrong interp vexp!!'
     stop
    end if

 else if (D01(jyprlow,japrup,jjzpr).eq.0) then       !no-default

    vdF=blip(yj,Aj,vND(:,:,jjzpr),yypr,aapr)

 else
    vtemp_ND=blip(yj,Aj,vND(:,:,jjzpr),yypr,aapr)

    if(interp_vexp_c.eq.1) then !25feb15
     vtemp_D =blip(yj,Aj, vDold(:,:,jjzpr),yypr,aapr)    !10feb15: vDold for vD
    else
         write(*,*) 'wrong interp vexp!!'
     stop
    end if


    if ( vtemp_ND.ge.vtemp_D) then
      vdF=vtemp_ND
    else
      vdF=vtemp_D
    end if

 end if

 end function vdF

 end function vexpND_c

  function vvND_c(bbb)
   implicit none
   real(prec) :: bbb, vvND_c
   vvND_c=utt_c(bbb,zero)+beta*vexpND_c(bbb)
  end function vvND_c

  function negat_vvND_c(bb)
   implicit none
    real(prec) :: bb
   real(prec) :: negat_vvND_c
   negat_vvND_c=-vvND_c(bb)
  end function negat_vvND_c

  subroutine vexpND_array_defi
   implicit none
      do ja=1,na
       do jz=1,nz
   do jb=1, nB
     vexpND_array(jb,ja,jz)=vexpND_c(Bj(jb))
   end do
    end do
    end do
  end subroutine vexpND_array_defi

  subroutine uttND_array_defi
   implicit none
   do jb=1, nB
     uttND_array(jb)=utt_c(Bj(jb),zero)
   end do
  end subroutine uttND_array_defi


! *******************************************************
  subroutine  mpiagentND_opt !mpi
  use interp
  implicit none
  integer, dimension(1)::ishit1
  real(prec) :: praxis, local_min, glomin, golden
  integer :: prin
  integer :: it
  real(prec) :: bb
 !compass-related
  real(prec), dimension(1)  ::  bbi
  real(prec) :: funceval
  integer :: kmax, k
  real(prec), dimension(2) :: bbold
  real(prec), dimension(:), allocatable ::  v_temp(:,:,:) !22jul14
  real(prec) :: machep !31may15

  external praxis
  external local_min, glomin

! -----open mpi------------ !mpi
    integer :: n_top, n_end, n0,  j_mpi
    real(prec),dimension(:),allocatable:: vtemp_mpi(:), vtemp_mpii(:)
    real(prec),dimension(:),allocatable:: BNDc_mpi(:)
    real(prec),dimension(:),allocatable:: BNDc_mpii(:)
!08oct20    real(prec), dimension(:), allocatable :: &
!08oct20    & errBND_temp(:), errmaxBND_temp(:) !03jun20
    ! .. mpi - allocate to processors ..
	!determines number of integer assigned to each node
	do n0=1,n_mpi
		if (n0*nproc>=n_mpi) exit
	end do
    allocate( vtemp_mpi(n0), &
     & BNDc_mpi(n0) )
    allocate( vtemp_mpii(n0*nproc), &
     & BNDc_mpii(n0*nproc))
	! .. compute Ntop and Nend for each processor id ..
	n_top=id*n0+1
	n_end=min((id+1)*n0,n_mpi) !notice n0*nproc might be above n
!08oct20   allocate( errBND_temp(0:nproc-1), errmaxBND_temp(0:nproc-1)) !03jun20
! ------- close mpi -----------


   allocate ( v_temp(1:ny,1:nA,1:nz) )


    ! .. Draw figure of value as a function of B (for secific ja, jz, jy) ..
IF(ID==0) THEN !10jan18
    if(draw_valND.eq.1) then

    open(297, file='valueND_fig.dat')
      ja= ja_valND
      write(297,*) 'ja=',ja_valND, 'jz=',jz_valND, 'jy=', jy_valND !10jan17
      write(297,'(a,a9,a14)') 'ja', 'B', 'val'
           jz=jz_valND
           jy=jy_valND
           bb= Bj(1) !zero
           do while(bb.lt.Bj(nB))
             write(297,'(i3,f9.4,f14.4)') ja, bb, vvND_c(bb)
             bb=bb+0.0001 !0.0005
           end do
    close(297)
    end if
END IF

IF(ID==0) then !10jan18
    open(297, file='BellRHS_ND_fig.dat')
    write(297,'(3a3,x,a14,a14,a14,a9,a9,a9)') 'ja','jz','jy',    &
           &   'vND ', 'vNDold ', &
           &   '(vD- vDold)', &
           &   'BND ', 'BNDold ', &
           &   '(BD -BDold)'
END IF





    ! .. STEP 1 (prelim) ..
        call vexpND_array_defi

!03jun20    errBND=zero
!03jun20    errmaxBND = zero
!08oct20        errmaxBND_temp(:)=zero
!08oct20        errBND_temp(:)=zero
! -----open mpi------------ !mpi !02mar16
    do j_mpi= n_top, n_end
            ja=ja_mpi(j_mpi)
            jz=jz_mpi(j_mpi)
            jy=jy_mpi(j_mpi)
! -----close mpi------------



    ! .. STEP 1:initialise on the grid using maxloc ..
            call uttND_array_defi
            ishit1=maxloc(&
                &  uttND_array(1:nB)+beta*vexpND_array(1:nB,ja,jz)  )
            locBND(jy,ja,jz) =ishit1(1)+1-1

    ! .. STEP 2: optimise off the grid by interpolating  ..


     if( (locBND(jy,ja,jz).gt.1).and.(locBND(jy,ja,jz).lt.nB).and. &
        & (-negat_vvND_c(Bj(locBND(jy,ja,jz))).gt.-negat_vvND_c(Bj(max(1,locBND(jy,ja,jz)-1)))).and. & !28mar16
        & (-negat_vvND_c(Bj(locBND(jy,ja,jz))).gt.-negat_vvND_c(Bj(min(nB,locBND(jy,ja,jz)+1))))  ) then
       v_temp(jy,ja,jz)=-golden( Bj(locBND(jy,ja,jz)-1), Bj(locBND(jy,ja,jz)), Bj(locBND(jy,ja,jz)+1), &
        &   negat_vvND_c, tol0_1dim,  bb )
     else
        v_temp(jy,ja,jz)=-negat_vvND_c(Bj(locBND(jy,ja,jz)))
        !if(locBND(jy,ja,jz).eq.1) bb=Bj(1)
        !if(locBND(jy,ja,jz).eq.nB) bb=Bj(nB)
        bb=Bj(locBND(jy,ja,jz))
     end if


    ! .. new policy off grid ..
    BND_c(jy,ja,jz)=bb
!08oct20    BND_c(jy,ja,jz)=speed_adjBD*bb+(one-speed_adjBD)*BND_cold(jy,ja,jz) !05jun15
!08oct20    v_temp(jy,ja,jz)= vvND_c(BND_c(jy,ja,jz)) !05jun15

IF(ID==0) then !10jan18
    ! .. compare outcomes across iterations ..
    write(297,'(3i3,x,f14.4,f14.4,f14.4,f9.4,f9.4,f9.4)') ja,jz,jy,    &
           &   v_temp(jy,ja,jz), vNDold(jy,ja,jz), &
           &   abs(v_temp(jy,ja,jz)- vNDold(jy,ja,jz)), &
           &   BND_c(jy,ja,jz), BND_cold(jy,ja,jz), &
           &   abs(BND_c(jy,ja,jz)-BND_cold(jy,ja,jz))
END IF
!03jun20     errmaxBND=max(errmaxBND,abs(BND_c(jy,ja,jz)-BND_cold(jy,ja,jz)))
!03jun20     errBND=errBND+abs(BND_c(jy,ja,jz)-BND_cold(jy,ja,jz))
!08oct20    errmaxBND_temp(id)=max(errmaxBND_temp(id),abs(BND_c(jy,ja,jz)-BND_cold(jy,ja,jz)))  !03jun
!08oct20    errBND_temp(id)=errBND_temp(id)+abs(BND_c(jy,ja,jz)-BND_cold(jy,ja,jz)) !03jun

!08oct20    ! .. locate on grid ..
!08oct20            locBND(jy,ja,jz) = count(Bj.le.bb)
!08oct20            if(       abs(Bj(locBND(jy,ja,jz))-bb) &
!08oct20                & .gt.abs(Bj(min(locBND(jy,ja,jz)+1,nB))-bb)) &
!08oct20                & locBND(jy,ja,jz) = min(locBND(jy,ja,jz)+1,nB)


! -----open mpi------------ !mpi
            vtemp_mpi(j_mpi-n_top+1)=v_temp(jy,ja,jz)
            BNDc_mpi(j_mpi-n_top+1)=BND_c(jy,ja,jz)
    end do !i_mpi

 call MPI_BARRIER(MPI_COMM_WORLD,IERROR)

 call MPI_ALLGATHER(vtemp_mpi(1), n0, MPI_DOUBLE_PRECISION, &
    	         &  vtemp_mpii(1), n0, MPI_DOUBLE_PRECISION, &
                 &  MPI_COMM_WORLD, ierror)
 call MPI_ALLGATHER(BNDc_mpi(1), n0, MPI_DOUBLE_PRECISION, &
    	         &  BNDc_mpii(1), n0, MPI_DOUBLE_PRECISION, &
                 &  MPI_COMM_WORLD, ierror)

!!** call MPI_BARRIER(MPI_COMM_WORLD,IERROR)

    do j_mpi= 1, n_mpi
            v_temp(jy_mpi(j_mpi),ja_mpi(j_mpi),jz_mpi(j_mpi)) &
                    & = vtemp_mpii(j_mpi)
            BND_c(jy_mpi(j_mpi),ja_mpi(j_mpi),jz_mpi(j_mpi)) &
                    & = BNDc_mpii(j_mpi)
    end do !i_mpi
    deallocate(vtemp_mpi,BNDc_mpi)
    deallocate(vtemp_mpii,BNDc_mpii)
!  -----close mpi------------

!08oct20
     errmaxBND=maxval(abs(BND_c(:,:,:)-BND_cold(:,:,:)))
     errBND=sum(abs(BND_c(:,:,:)-BND_cold(:,:,:)))
     errBND=errBND/real(ny*nA*nz)

!08oct20
    BND_c(:,:,:)=speed_adjBD*BND_c(:,:,:)+(one-speed_adjBD)*BND_cold(:,:,:)

    do jz=1, nz
     do ja = 1, nA
      do jy=1, ny
        v_temp(jy,ja,jz)= vvND_c(BND_c(jy,ja,jz))
        ! .. locate on grid ..
            locBND(jy,ja,jz) = count(Bj.le.BND_c(jy,ja,jz))
            if(       abs(Bj(locBND(jy,ja,jz))-BND_c(jy,ja,jz)) &
                & .gt.abs(Bj(min(locBND(jy,ja,jz)+1,nB))-BND_c(jy,ja,jz))) &
                & locBND(jy,ja,jz) = min(locBND(jy,ja,jz)+1,nB)
      end do
     end do
    end do


    vND=v_temp

IF(ID==0)      close(297) !10jan18
      !stop
   deallocate ( v_temp)
!08oct20   deallocate(errBND_temp,errmaxBND_temp) !03jun20
  end subroutine  mpiagentND_opt

! *******************************************************
  subroutine  agentALL_opt
  implicit none

IF(ID==0) then !10jan18
    open(297, file='D01diff_fig.dat') !12feb15
    write(297,'(3a3,x,3a8,3a9)') 'ja','jz','jy',    &
           &   'D01 ', 'D01old ', &
           &   'abs(D01-D01old)', &
           &   'abs(H-Hold)', &
           &   'abs(B-Bold)', 'abs(D-Dold)'
END IF

 do jz=1, nz
  do ja = 1, nA
   do jy=1,ny


  if(vD(jy,ja,jz).gt.vND(jy,ja,jz)) then
    D01(jy,ja,jz)=1
    B_c(jy,ja,jz)=BD_c(jy,ja,jz)
    D_c(jy,ja,jz)=DD_c(jy,ja,jz)
  else
    D01(jy,ja,jz)=0
    B_c(jy,ja,jz)=BND_c(jy,ja,jz)
    D_c(jy,ja,jz)=zero
  end if

 if(useD01old.eq.1) then
  D01(jy,ja,jz)=D01old(jy,ja,jz)
  if(D01(jy,ja,jz).eq.1) then
    B_c(jy,ja,jz)=BD_c(jy,ja,jz)
    D_c(jy,ja,jz)=DD_c(jy,ja,jz)
  else
    B_c(jy,ja,jz)=BND_c(jy,ja,jz)
    D_c(jy,ja,jz)=zero
  end if
 end if

IF(ID==0) then !10jan18
    ! .. compare outcomes across iterations ..
    write(297,'(3i3,x,i8,i8,i8,f9.4,f9.4,f9.4)') ja,jz,jy,    &
           &   D01(jy,ja,jz), D01old(jy,ja,jz), &
           &   abs(D01(jy,ja,jz)- D01old(jy,ja,jz)), &
           &   abs(H(jy,ja,jz)- Hold(jy,ja,jz)), &
           &   abs(BD_c(jy,ja,jz)-BD_cold(jy,ja,jz)), &
           &   abs(DD_c(jy,ja,jz)-DD_cold(jy,ja,jz))
END IF

   end do
  end do
 end do


IF(ID==0)  close(297) !10jan18
  end subroutine  agentALL_opt

!*************************************************************
! [4.] FUNCTIONS  FOR HOUSEHOLD
!*************************************************************
  function psi(defxR,jz_psi,Anext)
    implicit none
    real(prec) :: psi, defxR
    real(prec) :: Anext !07jun15
    !07jun13 real(prec) :: upperdef
    integer :: jz_psi !10apr13
    real(prec) :: zstar !04jan18

    if(jzstar.eq.0) then
     zstar=zero
    else
     zstar=zj(jzstar)
    end if

    if(defxR.ge.minimaldef) then !23nov17
     if(jz_psi.le.jzstar) then
        psi=psi0(jz_psi)* &
         &  (one-(one-Psimin)*(defxR**gamma_psi)) * &
         &  (one-(one-Psimin_A)*((Anext/target_Psimin_A)**gamma_psi_A)) !07jun15
     else
        psi=psi0(jz_psi)* &
         &  (one-phi1*(zj(jz_psi)-zstar)) * & !(one-phi1*(zj(jz_psi)-zj(jzstar)))
         &  (one-(one-Psimin)*(defxR**gamma_psi))* &
         &  (one-(one-Psimin_A)*((Anext/target_Psimin_A)**gamma_psi_A)) !07jun15
     end if
    else
        psi=one
    end if

  end function psi

 function utt(ctt)
    implicit none
    real(prec) :: utt, ctt
    if(ctt.gt.0.00001_prec) then
        utt=(((ctt)**(one-sigma))/(one-sigma))  !!*1000.0_prec !20sep15
    else
        utt=-huge
    end if
 end function utt



!*************************************************************
! [5.] LENDER  GIVEN CONTINUATION
!*************************************************************
 subroutine delta_HDexp_defi
  use interp
  implicit none
  real(prec) ::  val1, val2, val
  real(prec) :: aapr
  integer :: jjzpr
  real(prec) :: limits_eps(2)

  real(prec), dimension(:), allocatable ::  H2(:) !11dec12
  allocate ( H2(ny) )

  limits_eps(1)=lowereps
  limits_eps(2)=uppereps

    delta_HDexp=zero

    do jy=1, ny
     do ja=1, nA
      do jz= 1, nz
       do iR=1, nR !16oct14
        aapr=max(zero,delta*Aj(ja))+B_c(jy,ja,jz)+ &
            & (one-delta)*Rbar(iR)*DD_c(jy,ja,jz)*Aj(ja) !05feb15 !16oct14
        aapr=max(aapr,Aj(1)) !02jun15

        do jjzpr=1, nz
               delta_HDexp(jy,ja,jz)= delta_HDexp(jy,ja,jz) + &
                & piR(iR)*(delta+ (one-delta)*Rbar(iR)*DD_c(jy,ja,jz) &
                & -((DD_c(jy,ja,jz))**varphi)*barc & !01may15
                &   )* &  !05feb15
                & piz(jz,jjzpr)*HdF(zero) & !01feb15
                & *m_stochdisc !03jan18
        end do

       end do !iR

     end do
    end do
   end do

   contains

 function HdF(epspr) !01feb15
    implicit none !02apr18
    real(prec) :: HdF, epspr, yypr
    yypr=(zj(jjzpr)+epspr)*psi(DD_c(jy,ja,jz),jjzpr,aapr)
    yypr=max(yj(1), yypr)
    yypr=min(yj(ny), yypr)
    aapr=max(Aj(1), aapr) !02oct15
    aapr=min(Aj(na), aapr) !02oct15

            HdF= blip(yj,Aj,H(:,:,jjzpr),yypr,aapr)

 end function HdF


 end subroutine delta_HDexp_defi
!****************************************************************
!05sep15
 subroutine delta_HNDexp_defi
  use interp
  implicit none
  real(prec) ::  val1, val2, val
  real(prec) :: aapr
  integer :: jjzpr
  real(prec) :: limits_eps(2)

  real(prec), dimension(:), allocatable ::  H2(:) !11dec12
  allocate ( H2(ny) )

  limits_eps(1)=lowereps
  limits_eps(2)=uppereps

    delta_HNDexp=zero

        ! .. build spline v in vexp_c(if spline used)..
        if(interp_Hexp.eq.2) then
         do jjzpr=1, nz
          call splie2(yj,Aj,H(:,:,jjzpr),H2d(:,:,jjzpr))
         end do
        end if
        if(interp_Hexp.eq.3) then
         do jjzpr=1, nz
          call splie2_lip_spl(yj,Aj,H(:,:,jjzpr),H2d(:,:,jjzpr))
         end do
        end if
        ! .. end build splines ..

    do jy=1, ny
     do ja=1, nA
      do jz= 1, nz
       do iR=1, nR
        aapr=max(zero,delta*Aj(ja))+B_c(jy,ja,jz)
        aapr=max(aapr,Aj(1))


        do jjzpr=1, nz
               delta_HNDexp(jy,ja,jz)= delta_HNDexp(jy,ja,jz) + &
                & piR(iR)*(delta                               &
                &   )* &
                & piz(jz,jjzpr)*HdF(zero) & !01feb15
                & *m_stochdisc !03jan18
        end do


       end do !iR
     end do
    end do
   end do

   contains

 function HdF(epspr) !01feb15
    implicit none !02apr18
    real(prec) :: HdF, epspr, yypr
    yypr=(zj(jjzpr)+epspr)
    yypr=max(yj(1), yypr)
    yypr=min(yj(ny), yypr)
    aapr=max(Aj(1), aapr)  !02oct15
    aapr=min(Aj(na), aapr) !02oct15
            HdF= blip(yj,Aj,H(:,:,jjzpr),yypr,aapr)
 end function HdF


 end subroutine delta_HNDexp_defi

!*************************************************************
! FIND EQUILIBRIUM
!*************************************************************
! [6.] AGENT
!*************************************************************
 subroutine agent_iter
    implicit none
   integer :: errorloc(3)

    errorjdec=1000000000
    errmaxvD=vtol + 100.0_prec  !30jul13

     locBDold=locBD
     locDDold=locDD
     BD_cold=BD_c
     DD_cold=DD_c
     vDold=vD

     locBNDold=locBND !03feb15
     BND_cold=BND_c
     vNDold=vND

     D01old=D01 !12feb15

     call mpiagentD_opt !mpi
     call mpiagentND_opt !mpi
     call agentALL_opt !04feb15


     errorjdec=  count((locBDold.ne.locBD).or.(locDDold.ne.locDD)) !19aug14
     errmaxvD=maxval(abs(vD(:,:,:)-vDold(:,:,:)))
     errvD=sum(abs(vD(:,:,:)-vDold(:,:,:)))/real(ny*nA*nz) !02aug14

     vD=speed_adjv*vD+(one-speed_adjv)*vDold
     vND=speed_adjv*vND+(one-speed_adjv)*vNDold !21feb15

IF(ID==0) then !10jan18
    write(defout,*) '***************************************************',  iter
    write(defout,*) 'errmaxv=', errmaxvD, 'errorjdec=', errorjdec
    errorloc=maxloc(abs(vD(:,:,:)-vDold(:,:,:)))
    write(defout,*) 'errmaxBD=', errmaxBD, 'errmaxDD=', errmaxDD  !19aug14
    write(defout,*) 'max val = ', errorloc
    write(defout,*) 'errmaxBND=', errmaxBND !03feb15
    write(defout,*) 'errmaxD01=', count(D01old.ne.D01) !12feb15

    if (writev.eq.1) call write_vD
    if (writeBandD.eq.1) then !13apr13
        call write_BD
        call write_DD
        call write_BND
    end if
    if (writevND.eq.1) call write_vND   !03feb15
    if (writeD01.eq.1) call write_D01   !04feb15
END IF

 end subroutine agent_iter

!*************************************************************
! [7.] LENDER'S VALUE
!*************************************************************
 subroutine lender_iter
    use interp
    implicit none
    integer :: iter
    real(prec), dimension(:), allocatable ::  HD_temp(:,:,:),HND_temp(:,:,:) !05sep15

    real(prec) :: thetaA !15dec15

    allocate (HD_temp(1:ny,1:nA,1:nz),HND_temp(1:ny,1:nA,1:nz) ) !24feb15

    errmaxH=Htol+100.0_prec !30jul13

    iter=1

    do while((errmaxH.gt.Htol))
     Hold=H
     HDold=HD !05sep15
     HNDold=HND !05sep15

    call delta_HDexp_defi !05sep15
    call delta_HNDexp_defi !05sep15

IF(ID==0) then !10jan18
    open(297, file='HvalRHS_fig.dat')
    write(297,'(3a3,x,a14,a14,a14,a14,a9,a9,a9,a9)') 'ja','jz','jy',    &
           &   'H ', 'Hold ', &
           &   'abs(H- Hold)', &
           &   'deltaH', &
           &   'BD ', 'BDold ', &
           &   'DD ', 'DDold '
END IF

    do jz= 1, nz
     do ja=1, nA
      do jy=1, ny !12feb15

      thetaA=zero
      if(Aj(ja).gt.target_Psimin_A) &
       & thetaA=one-(target_Psimin_A/Aj(ja))**gamma_psi_A !15dec15

      HD_temp(jy,ja,jz)=(one-DD_c(jy,ja,jz))  +   & !20dec16
        & (one-thetaA*DD_c(jy,ja,jz))*q0*(delta_HDexp(jy,ja,jz) ) !15dec15

      HND_temp(jy,ja,jz)=one  + q0*(delta_HNDexp(jy,ja,jz) ) !20dec16 !05sep15

IF(ID==0) then !10jan18
    ! .. compare outcomes across iterations ..
    write(297,'(3i3,x,f14.4,f14.4,f14.4,f14.4,f9.4,f9.4,f9.4,f9.4)') ja,jz,jy,    &
           &   HD_temp(jy,ja,jz), HDold(jy,ja,jz), &
           &   abs(HD_temp(jy,ja,jz)- HDold(jy,ja,jz)), &
           &    delta_HDexp(jy,ja,jz), &
           &   BD_c(jy,ja,jz), BD_cold(jy,ja,jz), &
           &   DD_c(jy,ja,jz), DD_cold(jy,ja,jz)
END IF

      end do
     end do
    end do

IF(ID==0)    close(297) !10jan18

    HD=HD_temp
    HND=HND_temp
    do ja=1, nA
     do jz= 1, nz
      do jy=1, ny !12feb15
        if(D01(jy,ja,jz).eq.1) then
         H(jy,ja,jz)=HD(jy,ja,jz)
        else if (D01(jy,ja,jz).eq.0) then
         H(jy,ja,jz)=HND(jy,ja,jz)
        end if
      end do
     end do
    end do

     errmaxH=maxval(abs(H(:,:,:)-Hold(:,:,:)))
     errH=sum(abs(H(:,:,:)-Hold(:,:,:)))/real(ny*nA*nz) !02aug14

IF(ID==0)  write(defout,'(a10,f15.8)') 'errmaxH=', errmaxH !10jan18
     iter=iter+1
    end do

     H=speed_adjH*H+(one-speed_adjH)*Hold
     HD=speed_adjH*HD+(one-speed_adjH)*HDold !05sep15
     HND=speed_adjH*HND+(one-speed_adjH)*HNDold

IF(ID==0) then !10jan18
    write(defout,'(a16,f9.4)') 'Converged H!  error=', errmaxH

    if (writeh.eq.1) call write_hD  !16sep12
    if (writeh.eq.1) call write_hND !05sep15
    if (writeh.eq.1) call write_h   !16sep12
END IF

 deallocate(HD_temp,HND_temp) !24feb15

 end subroutine lender_iter


!*************************************************************
! [8.] UPDATE PRICES
!*************************************************************
 subroutine updques
    use interp
    implicit none
    integer :: jypr
    real(prec) :: ypr, val1, val2, val, parsum
  real(prec), dimension(:), allocatable ::  H2(:) !11dec12
  real(prec) :: prob_l, prob_h !01jun13
  real(prec) :: apr !12apr13
  real(prec) :: limits_eps(2)
  real(prec), dimension(:), allocatable ::  qqtilold(:,:,:)

  allocate (qqtilold(nAzero:nA,1:nD,1:nz)  )

  allocate ( H2(ny) )


    open(297, file='Qdiff_fig.dat') !03jun15
    write(297,'(3a3,x,3a10)') 'ja','jd','jz',    &
           &   'qqtil ', 'qqtilold ', &
           &   'abs(Q-Qold)'

  limits_eps(1)=lowereps
  limits_eps(2)=uppereps


    qqtilold=qqtil
    errmaxq=zero

    do jz= 1, nz
    do jd= 1, nD
    do ja= nAzero, nA !03sep15
      if(ja.gt.nA) then !30oct12 !07apr13     !08jan13
        qqtil_temp(ja,jd,jz)= qqtil_temp(ja,jd,jz)
      else
       parsum=zero
       do jzpr=1, nz

        parsum= parsum + &
            & piz(jz,jzpr)*HdF(zero) & !01feb15
            & *m_stochdisc !03jan18

       end do

       qqtil_temp(ja,jd,jz)=q0*parsum !07apr13
       qqtil(ja,jd,jz)= speed_adjq*qqtil_temp(ja,jd,jz) & !07apr13
                & +(one-speed_adjq)*qqtilold(ja,jd,jz)
      end if !30oct12

IF(ID==0) & !10jan18
     & write(297,'(3i3,x,f10.5,f10.5,f10.5)') ja,jd,jz,    & !03jun15
           &   qqtil_temp(ja,jd,jz), qqtilold(ja,jd,jz), &
           &   abs(qqtil_temp(ja,jd,jz)- qqtilold(ja,jd,jz))


      end do
     end do
    end do

    errmaxq=maxval(abs(qqtilold-qqtil_temp))
    errq= sum(abs(qqtilold-qqtil_temp))/real((nB-(nBzero+1)+1)*nD*nz) !02aug14

IF(ID==0) & !10jan18
    & write(defout,*)      'errmaxq= ', errmaxq, &
            & 'non-conv= ', count((abs(qqtilold(:,:,:)-qqtil_temp(:,:,:))).gt.qtol) !/real((nB-nBzero)*nD*nz) !'(a20,f9.4)'

IF(ID==0) THEN  !10jan18
     if (writeq.eq.1) call write_q
END IF

 close(297)


 contains
 function HdF(epspr) !01feb15
    implicit none !02apr18
    real(prec) :: HdF, epspr, ypr
    real(prec) :: vtemp_ND, vtemp_D !05sep15
    integer :: jyprlow, jyprup !05sep15
    ypr=(zj(jzpr)+epspr)*psi(Dj(jd),jzpr,Aj(ja)) !07jun15
    ypr=max(yj(1), ypr)
    ypr=min(yj(ny),ypr)

    ! .. locate interval containing (yypr)
    jyprlow=count(yj.le.ypr)
    jyprup=min(jyprlow+1,ny)

 if(D01(jyprup,ja,jzpr).eq.1) then
    HdF=lip(yj,HD(:,ja,jzpr),ypr)
 else if (D01(jyprlow,ja,jzpr).eq.0) then
    HdF=lip(yj,HND(:,ja,jzpr),ypr)
 else
    vtemp_D=lip(yj,vD(:,ja,jzpr),ypr)
    vtemp_ND=lip(yj,vND(:,ja,jzpr),ypr)
    if ( vtemp_ND.ge.vtemp_D) then
      HdF=lip(yj,HND(:,ja,jzpr),ypr)
    else
      HdF=lip(yj,HD(:,ja,jzpr),ypr)
    end if
 end if

 end function HdF

 end subroutine updques

!*************************************************************
! .. Price function used by hhold ..

 subroutine qqmap
  use interp
  implicit none
  integer :: japr
  real(prec) :: atarget, aRpr !24apr14

        qq(nBzero:nB,:,:,:)=zero !16oct14
        if((nobuybacks.eq.0).and.(nBzero.gt.1)) qq(1:nBzero-1,:,:,:)=zero !01dec15


     do jz= 1, nz
      do ja= 1, nA
       do jd= 1, nD
        do jb= 1, nB !13sep14  !01dec15

        do iR=1, nR !16oct14
        atarget=max(zero,delta*Aj(ja))+Bj(jb)+ (one-delta)*Rbar(iR)*Dj(jd)*Aj(ja) !16oct14
        if((atarget.ge.Aj(nAzero)).and.(atarget.le.Aj(nA))) then  !29jun14
          qq(jb,jd,ja,jz)= qq(jb,jd,ja,jz) + & !16oct14
            &   piR(iR)*   &        !16oct14
            &  lip(Aj(nAzero:nA),qqtil(:,jd,jz),atarget) !29jun14 !26jun14
        end if
        end do !16oct14

    end do
   end do
  end do
 end do


 end subroutine qqmap

!*************************************************************
! [9.] Solve EQUIL PRICES
!*************************************************************
 subroutine prices_iter
  implicit none

  real(prec) :: adum !11set14
  integer :: niter_local !250oct15

    integer :: beginning, rate, end !12jan18

 if (finiteec.gt.0) then !25oct15
    niter_local=niter_finiteec
 else
    niter_local=niter_nofiniteec
 end if

  errmaxq=huge

    iter=0 !10nov12

  do while((iter.lt.niter_local).and.(max(errmaxq,errmaxH,errmaxDD,errmaxvD).gt.tolall)) !24jun17
  !do while((iter.lt.niter_local)) !03jun20

call system_clock(beginning, rate) !12jan18


    if((speed_adjq.lt.0.90_prec)) then !25oct15
        call updques
        call qqmap
        call agent_iter
        call lender_iter
    else
        call updques
        call qqmap
        call agent_iter
        call lender_iter
    end if

IF(ID==0) THEN
    write(outfile1,*)
    write(outfile1,*) 'iter ', iter
    write(outfile1,*) 'errmaxq= ', errmaxq, 'errq=', errq
    write(outfile1,*) 'errmaxvD=', errmaxvD, 'errvD=', errvD
    write(outfile1,*) 'errmaxH=', errmaxH, 'errH= ', errH
    write(outfile1,*) 'errmaxBD=', errmaxBD, 'errBD= ', errBD   !11aug14
    write(outfile1,*) 'errmaxDD=', errmaxDD, 'errDD= ', errDD
    write(outfile1,*) 'errmaxBND=', errmaxBND, 'errBND= ', errBND !03feb15
    write(outfile1,*) 'errD01=',    count(D01old.ne.D01), 'errorjdec=', errorjdec
END IF


call system_clock(end) !12jan18
IF(ID==0)  write(outfile1,*) "elapsed time: ", real(end - beginning) / real(rate)

    iter=iter+1 !10nov12
  end do




IF(ID==0) THEN      !10jan18
    if (writev.eq.2) call write_vD
    if (writeBandD.eq.2) then
        call write_BD
        call write_DD
        call write_BND
    end if
    if (writevND.eq.2) call write_vND
!    if (writeBND.eq.2) call write_BND
    if (writeD01.eq.2) call write_D01
    if (writeh.eq.2) call write_hD
    if (writeh.eq.2) call write_hND
    if (writeh.eq.2) call write_h
    if (writeq.eq.2) call write_q
END IF


 end subroutine prices_iter


!*************************************************************
! [10.] NUMERICAL FUNCTIONS
!*************************************************************
! function: locate_in_y
 function locate_in_y(x)
    implicit none
    real(prec) :: x
    integer :: locate_in_y
    integer :: jl, ju, jm
    logical :: ascnd
    ascnd= (yj(ny) >= yj(1))
        jl=0
        ju=ny+1
        do
         if(ju-jl<=1) exit
         jm=(ju+jl)/2
         if(ascnd.eqv.(x >= yj(jm))) then
            jl=jm
         else
            ju=jm
         end if
        end do
        if(x==yj(1)) then
         locate_in_y=1
        else if (x==yj(ny)) then
         locate_in_y=ny-1
        else
         locate_in_y = jl
        end if
 end function locate_in_y

! function: locate_in_A
 function locate_in_A(x)
    implicit none
    real(prec) :: x
    integer :: locate_in_A
    integer :: jl, ju, jm
    logical :: ascnd
    ascnd= (Aj(nA) >= Aj(1))
        jl=0
        ju=nA+1
        do
         if(ju-jl<=1) exit
         jm=(ju+jl)/2
         if(ascnd.eqv.(x >= Aj(jm))) then
            jl=jm
         else
            ju=jm
         end if
        end do
        if(x==Aj(1)) then
         locate_in_A=1
        else if (x==Aj(nA)) then
         locate_in_A=nA-1
!!        else if (x>=Aj(nA)) then !20feb14
!!         locate_in_A=nA-1
        else
         locate_in_A = jl
        end if
 end function locate_in_A


! This subroutine  sorts an array arr(1:n) into ascending numerical order
! while making corresponding rearrangemt of the array brr(1:n)
        SUBROUTINE piksr(n,arr,brr)
        INTEGER :: n
        REAL(prec) ::    arr(n), brr(n)
        INTEGER :: i,j
        REAL(prec) :: a, b

        do 12 j=2,n
        a=arr(j)
        b=brr(j)
                do 11 i=j-1,1,-1
                        if(arr(i).le.a) goto 10
                        arr(i+1)=arr(i)
                        brr(i+1)=brr(i)

 11                     continue
        i=0
 10     arr(i+1)=a
        brr(i+1)=b

 12     continue
        return
        END SUBROUTINE piksr


	FUNCTION rtbis(func,x1,x2,xacc)
!!	USE nrtype; USE nrutil, ONLY : nrerror
	IMPLICIT NONE
	REAL(8), INTENT(IN) :: x1,x2,xacc
	REAL(8) :: rtbis
!!	INTERFACE
!!		FUNCTION func(x)
!!		USE nrtype
!!		IMPLICIT NONE
!!		REAL(prec), INTENT(IN) :: x
!!		REAL(prec) :: func
!!		END FUNCTION func
!!	END INTERFACE
	INTEGER, PARAMETER :: MAXIT=40
	INTEGER :: j
	REAL(8) :: dx,f,fmid,xmid
    real(8) :: func
    external func
	fmid=func(x2)
	f=func(x1)
	if (f*fmid >= 0.0) then
        write(*,*) 'rtbis: root must be bracketed '
        write(*,*) 'jz jb jd ja ', jz, jb, jd, ja
        stop
    end if
	if (f < 0.0) then
		rtbis=x1
		dx=x2-x1
	else
		rtbis=x2
		dx=x1-x2
	end if
	do j=1,MAXIT
		dx=dx*0.5_8
		xmid=rtbis+dx
		fmid=func(xmid)
		if (fmid <= 0.0) rtbis=xmid
		if (abs(dx) < xacc .or. fmid == 0.0) RETURN
	end do
        write(*,*) 'rtbis: too many bisections'
        stop
	END FUNCTION rtbis


  ! .. The CDF of the standard Normal. (Abromowitz and Stegun) ..
    function cdf_nor_01(x_nor)
    implicit none !02apr18
    real(prec), parameter ::   b1 =  0.319381530, b2 = -0.356563782, &
                            &  b3 =  1.781477937, b4 = -1.821255978, &
                            &  b5 =  1.330274429, p  =  0.2316419
    real(prec)   :: cdf_nor_01, x_nor, cdf_nor
    real(prec) :: f_nor !density
    real(prec) :: t
    f_nor=exp( -0.5*(x_nor)**2.)/ &
            & ((2.*3.14159)**0.5)
    if(x_nor.ge.0.) then
        t = 1.0 / ( 1.0 + p * x_nor )
        cdf_nor_01= 1.0 - f_nor * t * &
            &   ( t *( t * ( t * ( t * b5 + b4 ) + b3 ) &
            &       + b2 ) + b1 )
    else
        t = 1.0 / ( 1.0 - p * x_nor )
        cdf_nor_01= f_nor * t * &
            &   ( t *( t * ( t * ( t * b5 + b4 ) + b3 ) &
            &       + b2 ) + b1 )
    end if
    end function cdf_nor_01

!20may14
  ! .. The density of the standard Normal. ..
    function f_nor_01(x_nor)
    implicit none !02apr18
    real(prec)   :: x_nor, f_nor_01
    f_nor_01=exp( -0.5*(x_nor)**2.)/ &
            & ((2.*3.14159)**0.5)
    end function f_nor_01


!01feb15
! Integration.for: Fortran subroutines and functions for numerical integration
!
! Alfred Maußner
! 8 March 2008
! GC_Int1
!
! Integrate a real valued function over [a,b], using Gauss-Chebyshev quadrature
!
! Usage:  y=GC_Int(f, d, n)
!
! Input: f := Real(8) pointer to the procedure that evaluates the function, usage must be y=f(x)
!        d := Real(8) 2 times 1 vector, d(1) lower, d(2) upper limit of integration
!        n := Integer(4), the number of nodes where f is to be evaluated in order to compute y
!
! Ouput: y := Real(8), the value of the integral of f(x) over [a,b]

      real(8) Function GC_Int1(f,d,n)
!!*	use IMSLF90
      integer(4) n
      real(8) f, d(2)
      integer(4) i
      real(8) x(n), z(n), sum, pi, dconst, y

      external f  !!*, dconst
!!*      pi=Dconst('pi')
       pi = 3.1415927_prec

!!    do i=1,n
!!       x(i)=dcos(((2.*i-1)/(2.*n))*pi)         ! zero of n-the degree Chebyshev polynomial
!!	   z(i)=(x(i)+1.)*(d(2)-d(1))*0.5 + d(1)   ! adjusted to [a,b]
!!	end Do

    do i=1,n
       x(i)=dcos(((2._prec*i-1._prec)/(2._prec*n))*pi)   ! zero of n-the degree Chebyshev polynomial
	   z(i)=(x(i)+1._prec)*(d(2)-d(1))*0.5_prec + d(1)   ! adjusted to [a,b]
	end Do

      sum=0
      do i=1,n
      if(z(i).gt.d(2)) z(i)=d(2) !temp1
      if(z(i).lt.d(1)) z(i)=d(1) !temp1
	   y=f(z(i))
!!*	   if (IsNan(y)) then
!!*	      GC_Int1=y
!!*		  Return
!!*	   endif
         sum=sum+y*dsqrt(1._prec-(x(i)**2._prec))
      end do

      sum=pi*(d(2)-d(1))*sum
      sum=sum/(2._prec*n)

      GC_Int1=sum

	return
	end function

! ************************************************************************************
! GH_INT1: Gauss-Hermite integration over a one-dimensional space using four points
!
! usage: x=GH_INT1(f)
!
! Input: f, Real(8) pointer to the function y=f(z1)
!           which is to be integrated
! Output: x, Real(8) value of the integral of y over [-inf,+inf]
!
! Remark: The integration nodes and weights (taken from Judd (1998), p. 262)
!         are stored in gcx and gcx, respectively and initialized with a data statement.
!         this takes place in the module GH_Def


	Real(8) Function GH_INT1(f,sigma)


!!	use GH_Def
!!	use Errors
!!	use IMSLF90

	Real(8) f, sigma

	Integer(4) i1
	Real(8) sum, s, temp, dconst, pi

	Real(8) ghx(1:4), ghw(1:4)

!	DATA ghx/-1.506801230,-0.5246476232,0.5246476232,1.506801230/
	DATA ghx/-1.6506801230,-0.5246476232,0.5246476232,1.6506801230/
	DATA ghw/ 0.08131283544,0.8049140900,0.8049140900,0.08131283544/

	
!	pi=dconst('pi')
    pi = 3.1415927_prec
	sum=0.0_prec
	s=2.0_prec
	s=dsqrt(s)*sigma
	Do i1=1,4
			temp=f(s*ghx(i1))
!!			if (FError.ne.0_prec) return
			sum=sum+temp*ghw(i1)
	End Do
	GH_INT1=sum*((pi)**(-1._prec/2._prec))

!    write(*,*) 'GH_INT1= ', GH_INT1
!   pause

	Return
	End Function

!**************************************************************
! [12.] SIMULATIONS
!**************************************************************
 subroutine simul_paths  !(ntime) !18feb17

 use interp

 implicit none

 integer :: time
 real(prec) :: parsum, qqqtil
 real(prec) :: x_z
 integer :: japr, jypr, jzpr

 integer, parameter:: nshocks=2 !10jul14 nshocks=4 !06mar14 nshocks=2 !09jan14
!04oct15 integer, parameter:: ntime=20000  !5000
 integer :: ntime
 real(prec), dimension(:), allocatable:: ran_out(:)
 integer, dimension(:), allocatable:: seed(:)

 real(prec), dimension(:), allocatable :: z(:),a(:),y(:),b(:),d(:),c(:),spread(:),tb(:),q(:)
 real(prec), dimension(:), allocatable ::  partdef(:) !15oct14

 real(prec) :: z_aver, logz_aver,logz_var, logz_corr
 real(prec) :: y_aver, logy_aver, a_aver, &
    & b_aver,d_aver,defrate,cons_aver,logc_aver,logc_var
 !real(prec) :: logy_corr, logy_var
  real(prec) :: spr_aver,  &  !01apr16 d_stdv,  spr_aver, spr_stdv, &
            & tb_aver, tb_stdv, corr_dtb !02oct13 !17oct14

   real(prec) :: debtdue,   debtdue_stdv, corr_ddebttoY !14feb17
   real(prec) ::  coupdef, coupdef_sd, coupdef_cond, coupdef_cond_sd !10feb21 debtserv, debtserv_sd,

!17oct14 real(prec) :: corr_tby, corr_dy !15oct14

 real(prec) :: logx_aver, logx_stdv, corrx, logy_stdv !09apr13

!04dec13 real(prec) :: AtoY, Spr, sdSpr, sdC, freqdef, corrSpr, corrC, corrEX !05aug13
 real(prec) :: sdSpr,   corrC, corrEX !04dec13  sdC,
 real(prec) :: sdEX !04dec13 !24sep13

 real(prec) :: x_rr !09jan14
 real(prec) :: x_a, x_y, prob_a_l, prob_y_l, atarget, ytarget !06mar14
 real(prec), dimension(:), allocatable :: trr(:), tAr(:)   !09jan14
 integer, dimension(:), allocatable ::  tR(:)   !09jan14

 integer :: jaup, jalow, jyup, jylow !07feb15
 real(prec) :: vtemp_ND, vtemp_D

 real(prec) :: x_R !16oct14
 real(prec), dimension(:), allocatable :: RRbar(:) !16oct14

 integer :: seed_eps !08feb15
 real(prec) :: x_eps
 real(prec) :: RRbartarget !10jan16

 integer :: ntime_temp !17feb17

!21jun17
 integer, dimension(:), allocatable :: deftime0(:),deftime1(:)
 integer :: defcount, ndefcount
 integer, dimension(:), allocatable :: lengthdef(:)
 real(prec), dimension(:), allocatable :: averdef(:), averspr(:), averdebttoy(:), avery(:)
! real(prec), dimension(:), allocatable ::   &
!        & initdebttoy(:), finaldebttoy(:), middebttoy(:) !10jan19
! real(prec), dimension(:), allocatable ::   &
!        & pre_initdebttoy(:), post_finaldebttoy(:) !09feb21
 real(prec), dimension(:), allocatable :: averhairc(:) !25jul18
 real(prec) r_aux, del_aux

 real(prec), dimension(:), allocatable ::   &
   &   pre_initdebttoy     (:), &
   &   initdebttoy         (:), &
   &   middebttoy          (:), &
   &   finaldebttoy        (:), &
   &   post_finaldebttoy   (:)
 real(prec), dimension(:), allocatable ::   &
   &   pre_initdef     (:), &
   &   initdef         (:), &
   &   middef          (:), &
   &   finaldef        (:), &
   &   post_finaldef   (:), &
   &   pre_initspr     (:), &
   &   initspr         (:), &
   &   midspr          (:), &
   &   finalspr        (:), &
   &   post_finalspr   (:), &
   &   pre_inity       (:), &
   &   inity           (:), &
   &   midy            (:), &
   &   finaly          (:), &
   &   post_finaly     (:), &
   &   pre_initc       (:), &
   &   initc           (:), &
   &   midc            (:), &
   &   finalc          (:), &
   &   post_finalc     (:)

 real(prec) :: haircut_stat, extension_stat, &
   &  length_aver_stat            , &
   &  length_sd_stat              , &
   &  corr_dlength_stat           , &
   &  corr_hairclength_stat       , &
   &  pre_initdebttoy_aver_stat   , &
   &  initdebttoy_aver_stat       , &
   &  middebttoy_aver_stat        , &
   &  finaldebttoy_aver_stat      , &
   &  post_finaldebttoy_aver_stat
 real(prec) ::  &
   &   pre_initdef_stat    , &
   &   initdef_stat        , &
   &   middef_stat         , &
   &   finaldef_stat       , &
   &   post_finaldef_stat  , &
   &   pre_initspr_stat    , &
   &   initspr_stat        , &
   &   midspr_stat         , &
   &   finalspr_stat       , &
   &   post_finalspr_stat  , &
   &   pre_inity_stat      , &
   &   inity_stat          , &
   &   midy_stat           , &
   &   finaly_stat         , &
   &   post_finaly_stat    , &
   &   pre_initc_stat      , &
   &   initc_stat          , &
   &   midc_stat           , &
   &   finalc_stat         , &
   &   post_finalc_stat

 CHARACTER(*), PARAMETER :: fileplace = "/data/home/tew158/partdef/v21/calibration/calib22mpi/simul/"

!    ntime=20000 !04oct15
!18feb17
    ntime=simulsize !50000 !13dec15

    allocate(deftime0(ntime),deftime1(ntime)) !21jun17

    allocate (ran_out(nshocks))
    allocate (seed(nshocks))
    allocate (z(ntime),a(ntime),y(ntime),b(ntime),d(ntime),c(ntime),q(ntime),tb(ntime),spread(ntime))
    allocate(RRbar(ntime)) !16oct14
    allocate (trr(ntime), tAr(ntime), tR(ntime) )   !09jan14
    allocate (partdef(ntime))!15oct14

IF(ID==0) THEN !10jan18
!  open (43, file='simulpaths_lined.dat')    !29mar14
  open(42, file=fileplace//'simulpaths.dat')
  !open (42, file='simulpaths.dat')
!  open (431, file='epsilon.dat') !02apr15
END IF

    ! for reprofiling analysis:
!    piR(1)= 0.20	    !26jul18
!    piR(2)= 0.80     !26jul18

! Initial States

!10jul14    jd=1
!    jB=nBzero
!    !04oct12 ja=(jd-1)*nB+jB
!    ja=ja_map(jB,jd,nAzero) !24may13 !04oct12
!    jz=nz
!    jy=locate_in_y(zj(jz))
!     if(abs(yj(jy)-zj(jz)).gt.abs(yj(jy+1)-zj(jz))) jy=jy+1

    jz=nz
    ytarget=zj(jz)
    atarget=zero

!09jan14    seed = (/ 7654321 /)
!06mar14    seed = (/ 7654321, 7354541 /) !09jan14
!10jul14    seed = (/ 7654321, 7354541, 5354751, 6384533 /) !06mar14
    seed = (/ 7654321, 7354541 /) !10jul14
    CALL random_seed(put=seed(1:nshocks))
    seed_eps = 5353543 !08feb15

!29mar14
IF(ID==0) THEN
!    write(43,*) ' --------------------'
!    write(43,*) ' PATHS '
!    write(43,*) ' --------------------'
!    write(43,*) 'time, y,  z, a, b, d,  R, c, spr ' !16oct14

    write(42,*) ' --------------------'
    write(42,*) ' PATHS '
    write(42,*) ' --------------------'
    write(42,*) 'time, y,  z, a, b, d, R, c, spr ' !16oct14
END IF

 noconv=0
 do time=1, ntime

    ! [0] .. States ..
    z(time)=zj(jz)
    a(time)=atarget
    y(time)=ytarget

    ! [1] .. Exogenous stochastic shocks ..
    CALL random_number(ran_out(1:nshocks))

    ! .. z next ..
    x_z=ran_out(1)

    ! .. x_eps next ..
    if(noise_epsV.eq.1) then
    call truncated_normal_ab_sample(avereps, sdeps, lowereps, uppereps, &
        & seed_eps, x_eps ) !08feb15
    else
        x_eps=zero
    end if

    ! .. x_R now ..
    x_R=ran_out(2) !16oct14


    ! [2] .. Current Rbar ..
    if(x_R.eq.one) then     !16oct14
        iR=nR
    else if(x_R.eq.zero) then
        iR=1
    else
        parsum=zero
        do iR=1, nR
            if((x_R.ge.parsum).and.(x_R.lt.parsum+piR(iR)))  exit
            parsum=parsum+piR(iR)
        end do
    end if


    RRbar(time)= Rbar(iR) !10jan16
    !write(*,*) 'iR= ', iR
    !write(*,*) 'Rbar= ', Rbar(iR)

    ! [3] .. endogenous decision and prices..

    !10jul14 b(time)=Bj(locBD(jy,ja,jz))
    !10jul14 d(time)=Dj(locDD(jy,ja,jz))*Aj(ja) !17apr14
!    b(time)= blip(yj,Aj,BD_c(:,:,jz),y(time),a(time))         !10jul14
!    d(time)= blip(yj,Aj,DD_c(:,:,jz),y(time),a(time))*a(time) !10jul14

!07feb15
    ! .. locate box containing (yypr, aapr)
    jylow=count(yj.le.y(time))
    jyup=min(jylow+1,ny)
    jalow=count(Aj.le.a(time))
    jaup=min(jalow+1,nA)
   if(D01(jyup,jalow,jz).eq.1) then   !default
    b(time)= blip(yj,Aj,BD_c(:,:,jz),y(time),a(time))
    if(do_counterfact.eq.3) b(time)=zero !25apr17
    d(time)= blip(yj,Aj,DD_c(:,:,jz),y(time),a(time))*a(time)
   else if (D01(jylow,jaup,jz).eq.0) then       !no-default
    b(time)= blip(yj,Aj,BND_c(:,:,jz),y(time),a(time))
    d(time)=zero
   else
    vtemp_ND=blip(yj,Aj,vND(:,:,jz),y(time),a(time))
    vtemp_D =blip(yj,Aj, vD(:,:,jz),y(time),a(time))
    if ( vtemp_ND.ge.vtemp_D) then
     b(time)= blip(yj,Aj,BND_c(:,:,jz),y(time),a(time))
     d(time)= zero
    else
     b(time)= blip(yj,Aj,BD_c(:,:,jz),y(time),a(time))
     if(do_counterfact.eq.3) b(time)=zero !25apr17
     d(time)= blip(yj,Aj,DD_c(:,:,jz),y(time),a(time))*a(time)
    end if
   end if


    if(a(time).gt.zero) then
        partdef(time)=d(time)/a(time)!15oct14
    else
        partdef(time)=zero
    end if

    if(b(time).ge.Bj(nBzero)) then !04aug14 !01dec15
        qqqtil=lininterp3(Bj(1:nB),Dj(1:nD),Aj(1:nA), &  !10jul14
                &   qq(1:nB,1:nD,1:nA,jz), &
                &   b(time),partdef(time),a(time)) !06mar16
!06mar16                &   b(time),d(time),a(time)) !10jul14
    else
      if(nobuybacks.eq.1) then !30nov15
        qqqtil=q0/(one-q0*delta) !10apr14
      else if(nobuybacks.eq.0) then !01dec15
        qqqtil=lininterp3(Bj(1:nB),Dj(1:nD),Aj(1:nA), &
                &   qq(1:nB,1:nD,1:nA,jz), &
                &   b(time),partdef(time),a(time)) !06mar16
!06mar16                &   b(time),d(time),a(time))
      end if
    end if


    q(time)=qqqtil !07mar14
    spread(time)= (((one/qqqtil)+delta)**modelfreq)-((one/q0)**modelfreq)
    c(time)=y(time)-(a(time)-d(time)) &
        & +qqqtil*b(time)
    tb(time)=y(time)-c(time) !09apr13

!!! pause

!10jul14    trr(time)=zero
!10jul14    tAr(time)=zero
!10jul14    if((ja.gt.nAzero).and.(locD(jy,ja,jz).gt.1)) then
!10jul14         trr(time)=      rr(locB(jy,ja,jz),locD(jy,ja,jz),ja,jz)     !09jan14
!10jul14         tAr(time)= Aj(locGamm(locB(jy,ja,jz),locD(jy,ja,jz),ja,jz))     !09jan14
!10jul14    else
!10jul14         trr(time)= zero     !09jan14
!10jul14         tAr(time)= zero     !09jan14
!10jul14    end if
!10jul14
!10jul14    if(x_rr.eq.one) then !09jan14
        tR(time)=0
!10jul14    else if(x_rr.eq.zero) then
!10jul14        tR(time)=1
!10jul14    else
!10jul14        if(x_rr.gt.trr(time)) tR(time)=0
!10jul14        if(x_rr.le.trr(time)) tR(time)=1
!10jul14    end if

    ! .. write stuff ..

IF(ID==0) THEN !10jan18
!!18feb17    if((time.ge.3000).and.(time.le.5000)) write(43,'( &
!    if(time.le.min(5000,ntime)) & !18feb17
!                    & write(43,'( &
!                    & i6,f10.6,f10.6,f10.6,a2, &
!                    & f10.6,f10.6,a2, &
!                    & f10.6,a2, &
!                    & f10.6,f10.6)') &
!        & time, y(time),  z(time), a(time), '¦', &
!        & b(time), d(time),'¦', &
!        & RRbar(time),  '¦', &  !16oct14
!        & c(time), spread(time)                 !09jan14

!!!!!!!!!!!!!!!!!!

!29mar14
!18feb17    if((time.ge.3000).and.(time.le.20000)) &
    if(time.le.min(5000,ntime)) & !18feb17
                    & write(42,'( &
                    & i6,f10.6,f10.6,f10.6, &
                    & f10.6,f10.6, &
                    & f10.6, &
                    & f10.6,f10.6)') &
        & time, y(time),  z(time), a(time),  &
        & b(time), d(time), &
        & RRbar(time),  &        !16oct14
        & c(time), spread(time)                 !09jan14
END IF

    ![4] .. Next period states ..
    if(x_z.eq.one) then
        jzpr=nz
    else if(x_z.eq.zero) then
        jzpr=1
    else
        parsum=zero
        do jzpr=1, nz
            if((x_z.ge.parsum).and.(x_z.lt.parsum+piz(jz,jzpr)))  exit
            parsum=parsum+piz(jz,jzpr)
        end do
    end if
    !Update
    jz=jzpr


!10jan16    !Next period Rbar
!10jan16    if(x_R.eq.one) then     !16oct14
!10jan16        iR=nR
!10jan16    else if(x_R.eq.zero) then
!10jan16        iR=1
!10jan16    else
!10jan16        parsum=zero
!10jan16        do iR=1, nR
!10jan16            if((x_R.ge.parsum).and.(x_R.lt.parsum+piR(iR)))  exit
!10jan16            parsum=parsum+piR(iR)
!10jan16        end do
!10jan16    end if

!!    atarget=b(time)+(one-delta)*Rbar(iR)*d(time)+max(delta*a(time),zero)
    atarget=max(Aj(1),b(time)+(one-delta)*Rbar(iR)*d(time)+max(delta*a(time),zero)) !28jun15
    !ytarget=zj(jzpr)*psi(d(time),jzpr) !06mar14

    !06mar16 ytarget=min((zj(jzpr)+x_eps)*psi(d(time),jzpr,atarget),yj(ny)) !07jun15 !08feb15
    ytarget=min((zj(jzpr)+x_eps)*psi(partdef(time),jzpr,atarget),yj(ny)) !06mar16 !07jun15 !08feb15


    !25apr17
    if(do_counterfact.eq.1) ytarget=min((zj(jzpr)+x_eps),yj(ny))
    if(do_counterfact.eq.2) atarget=max(Aj(1),b(time)+max(delta*a(time),zero))




!18oct14
!!*!03oct13
!!*!    if(time+1.eq.4070) jzpr=4
!!*!    if(time+1.eq.4071) jzpr=5
!!*!    if(time+1.eq.4072) jzpr=6
!!*!    if(time+1.eq.4073) jzpr=6
!!*!    if(time+1.eq.4074) jzpr=6
!!*!    if(time+1.eq.4075) jzpr=6
!!*
!!*
!!*  if(tR(time).eq.0) then !09jan14
!!*!06mar14     japr=ja_map(locB(jy,ja,jz),locD(jy,ja,jz),ja) !24may13 !04oct12
!!*!10jul14    atarget=Bj(locB(jy,ja,jz))+(one-delta)*Rbar*Dj(locD(jy,ja,jz))*Aj(ja) & !17apr14
!!*!10jul14            & +max(delta*Aj(ja),zero)   !06mar14
!!*!10jul14    japr=locate_in_A(atarget)           !06mar14
!!*!10jul14    prob_a_l=(Aj(japr+1)-atarget)/(Aj(japr+1)-Aj(japr)) !06mar14
!!*    atarget=b(time)+(one-delta)*Rbar*d(time)+max(delta*a(time),zero)   !10jul14
!!*  else if(tR(time).eq.1) then
!!*    !11jan14 japr=locGamm(locB(jy,ja,jz),locD(jy,ja,jz),ja,jz)
!!*!06mar14     japr=ja_mapGamm(locB(jy,ja,jz),locD(jy,ja,jz),ja,jz) !11jan14
!!*!10jul14    atarget=Aj(locGamm(locB(jy,ja,jz),locD(jy,ja,jz),ja,jz)) &
!!*!10jul14                & +Bj(locB(jy,ja,jz))  !06mar14
!!*!10jul14    japr=locate_in_A(atarget)           !06mar14
!!*!10jul14    prob_a_l=(Aj(japr+1)-atarget)/(Aj(japr+1)-Aj(japr)) !06mar14
!!*    atarget=Aj(locGamm(locB(jy,ja,jz),locD(jy,ja,jz),ja,jz))+b(time)
!!*  end if
!!*!06mar14
!!*
!!*!10jul14    if(x_a.eq.one) then
!!*!        japr=japr+1
!!*!    else if(x_a.eq.zero) then
!!*!        japr=japr
!!*!    else
!!*!        if(x_a.gt.prob_a_l) japr=japr+1
!!*!        if(x_a.le.prob_a_l) japr=japr
!!*!    end if
!!*
!!*
!!*  if(tR(time).eq.0) then !09jan14
!!*!06mar14    jypr=locate_in_y(zj(jzpr)*psi(d(time),jzpr)) !10apr13 !06apr13 !26mar13
!!*!06mar14     if(abs(zj(jzpr)*psi(d(time),jzpr)-yj(jypr)).gt.abs(zj(jzpr)*psi(d(time),jzpr)-yj(jypr+1)) ) jypr=jypr+1
!!*    ytarget=zj(jzpr)*psi(d(time),jzpr) !06mar14
!!*!10jul14    jypr=locate_in_y(ytarget)          !06mar14
!!*!10jul14    prob_y_l=(yj(jypr+1)-ytarget)/(yj(jypr+1)-yj(jypr))  !06mar14
!!*  else if(tR(time).eq.1) then
!!*!06mar14    jypr=locate_in_y(zj(jzpr)) !09jan14
!!*    ytarget=zj(jzpr)             !06mar14
!!*!10jul14    jypr=locate_in_y(ytarget)    !06mar14
!!*!10jul14    prob_y_l=(yj(jypr+1)-ytarget)/(yj(jypr+1)-yj(jypr))  !06mar14
!!*  end if
!!*!06mar14
!!*!    if(x_y.eq.one) then
!!*!        jypr=jypr+1
!!*!    else if(x_y.eq.zero) then
!!*!        jypr=jypr
!!*!    else
!!*!        if(x_y.gt.prob_y_l) jypr=jypr+1
!!*!        if(x_y.le.prob_y_l) jypr=jypr
!!*!    end if
!!*
!!*
!!*
!!*!10jul14    jy=jypr
!!*!10jul14    ja=japr


 end do !time


!IF(ID==0)  close(431) !02apr15 !10jan18

!pause
!write(*,*) 'problems?'

IF(ID==0) THEN !10jan18
! close(43) !29mar14
 close(42)
END IF
!17feb17
! .. Throw away the first 10% of observations ..

    ntime_temp=int(ntime*0.9)
    y(1:ntime_temp)=y(ntime-ntime_temp+1:ntime)
    z(1:ntime_temp)=z(ntime-ntime_temp+1:ntime)
    a(1:ntime_temp)=a(ntime-ntime_temp+1:ntime)
    b(1:ntime_temp)=b(ntime-ntime_temp+1:ntime)
    d(1:ntime_temp)=d(ntime-ntime_temp+1:ntime)
    RRbar(1:ntime_temp)=RRbar(ntime-ntime_temp+1:ntime)
    c(1:ntime_temp)=c(ntime-ntime_temp+1:ntime)
    spread(1:ntime_temp)=spread(ntime-ntime_temp+1:ntime)
    tb(1:ntime_temp)=tb(ntime-ntime_temp+1:ntime)
    partdef(1:ntime_temp)=partdef(ntime-ntime_temp+1:ntime) !04apr19

    ! .. reset ..
    ntime=ntime_temp

! .. stationary distrib ..
    if(dowelf.eq.1) call stationarydistrib !25oct21

open(47, file='final_stats.dat') !10feb21

if(modelfreq.eq.4) then !19feb21
IF(ID==0) THEN !10jan18
    write(outfile1,*) '--------------------'
    write(outfile1,*) 'QUARTERLY DATA'
    write(outfile1,*) '--------------------'
    write(outfile1,*)
END IF
 call report_stats
 call simulpaths_stats
IF(ID==0) THEN
 call defaultevents !22jul18
!25jul18 call slope_coeffs !22jul18
 r_aux=((one/q0))-one
 del_aux=delta
 call haircuts_extensions(r_aux,del_aux) !22jul18
 call slope_coeffs !25jul18 !22jul18
!22jul18
! deallocate(lengthdef,averdef)
! deallocate(averspr)
! deallocate(averdebttoy,avery)
! deallocate(initdebttoy, finaldebttoy, middebttoy) !10jan19
! deallocate(pre_initdebttoy, post_finaldebttoy) !09feb21
! deallocate(averhairc) !25jul18
write(47,*) '---------------'
write(47,*) 'QUARTERLY DATA'
write(47,*) '---------------'
call final_stats !10feb21
END IF

IF(ID==0) THEN !10jan18
    write(outfile1,*) '--------------------'
    write(outfile1,*) 'ANNUAL DATA'
    write(outfile1,*) '--------------------'
    write(outfile1,*)
END IF
 call annualdata !04oct15
 call report_stats
 call simulpaths_yr_stats
IF(ID==0) THEN !10jan18
 call defaultevents !21jun17
!25jul18 call slope_coeffs !11feb17
!15sep18 (one/q0)/((one/q0)-delta)=4.0_prec*(one+r_aux)/(one+r_aux-del_aux)
 r_aux=((one/q0)**modelfreq)-one
 del_aux=(one+r_aux)*((((one/q0)/((one/q0)-delta))/modelfreq)-one) &
        & /(((one/q0)/((one/q0)-delta))/modelfreq)
 !del_aux=delta**4.0_prec
! RRbar=Rbar(1)*0.95_prec !20sep18
! write(outfile1,*) 'Rbar= ', RRbar(1) !20sep18
! write(outfile1,*) '-----------------------' !20sep18
 call haircuts_extensions(r_aux,del_aux) !20jul18
 call haircbyvintage(r_aux,del_aux) !(((one/q0)**modelfreq)-one,delta**modelfreq)
  call slope_coeffs !25jul18 !11feb17
 call split_by_default !01apr17
write(47,*) '------------'
write(47,*) 'ANNUAL DATA'
write(47,*) '------------'
call final_stats !10feb21
END IF
end if !for modelfreq

if(modelfreq.eq.1) then !19feb21
 call report_stats
 call simulpaths_stats  !or call simulpaths_yr_stats
 call defaultevents

 r_aux=((one/q0))-one
 del_aux=delta
 call haircuts_extensions(r_aux,del_aux)
 call haircbyvintage(r_aux,del_aux)
 call slope_coeffs
 call split_by_default

 call final_stats
end if !for modelfreq



close(47) !10feb21

 deallocate(z,a,y,b,d,c,q,tb)


 contains
! *****************************************************************
!25oct21
 subroutine stationarydistrib
 ! Local to [simul_paths]
 ! Locals:     jy1    jy2    jz1    jz2    ja1    ja2
 !
 !          vals_y,inds_y vals_a,inds_a vals_z,inds_z
 ! Global: stdt (not needed, for now only want to write it out)
  implicit none
  integer :: jy1, jy2, jz1, jz2, ja1, ja2, iy, ia, iz, jy, ja, jz
  real(prec)    :: vals_y(2), vals_a(2), vals_z(2)
  integer       :: inds_y(2), inds_a(2), inds_z(2)

  real(prec), dimension(:), allocatable :: stdt(:,:,:)
  real(prec), dimension(:), allocatable :: &
    & stdt_posdef(:,:,:),stdt_zerodef(:,:,:)  !27oct21

  allocate ( stdt(1:ny,1:nA,1:nz))
  allocate ( stdt_posdef(1:ny,1:nA,1:nz),stdt_zerodef(1:ny,1:nA,1:nz)) !27oct21

  stdt=zero
  do time=1, ntime
    call basefun(yj,ny,y(time),vals_y,inds_y)
    call basefun(Aj,nA,a(time),vals_a,inds_a)
    call basefun(zj,nz,z(time),vals_z,inds_z)

    do iy=1, 2
     do ia=1, 2
      do iz=1, 2
        jy=inds_y(iy)
        ja=inds_a(ia)
        jz=inds_z(iz)
        stdt(jy,ja,jz)=stdt(jy,ja,jz)+vals_y(iy)*vals_a(ia)*vals_z(iz)
      end do
     end do
    end do

  end do

    stdt=stdt/real(ntime)


!27oct21
stdt_posdef=stdt
stdt_zerodef=stdt
    where (D01(:,:,:).eq.0)
        stdt_posdef(:,:,:)=zero
        stdt_zerodef(:,:,:)=stdt(:,:,:)
    elsewhere
        stdt_posdef(:,:,:)=stdt(:,:,:)
        stdt_zerodef(:,:,:)=zero
    end where
    stdt_posdef(:,:,:)=stdt_posdef(:,:,:)/sum(stdt_posdef)
    stdt_zerodef(:,:,:)=stdt_zerodef(:,:,:)/sum(stdt_zerodef)
    !write(*,*) 'sum(stdt_posdef) ',  sum(stdt_posdef)
    !write(*,*) 'sum(stdt_zerodef) ',  sum(stdt_zerodef)

    open(48, file='stdt.dat')
    write(48,'(3a5,3a14)') 'jy', 'ja', 'jz', 'stdt', 'posd', 'zerod'
    do jy=1, ny
     do ja=1, nA
      do jz=1, nz
      write(48,'(3i5,3f14.10)') jy, ja, jz, stdt(jy,ja,jz), &
        &   stdt_posdef(jy,ja,jz), stdt_zerodef(jy,ja,jz)
      end do
     end do
    end do
    close(48)

 deallocate ( stdt)
 deallocate (stdt_posdef,stdt_zerodef)  !27oct21

 end subroutine stationarydistrib
! *****************************************************************
!25oct21
 subroutine basefun (grid_x,npx,x,vals,inds)
 implicit none
  ! this subroutine returns the values and the indices of the two basis
  ! functions that are positive on a given x in the grid_x

  real(prec),intent(in) :: x
  integer , intent(in):: npx
  real(prec), intent(in) :: grid_x (npx)
  real(prec), intent(out) ::vals(2)
  integer ,intent(out) ::inds(2)
  integer :: i,ju,jl,jm

  jl=1
  ju=npx   	

  do

  if (ju-jl<=1)  exit
  jm=(ju+jl)/2
  if (x>=grid_x(jm)) then
  	jl=jm
  else
  	ju=jm
  endif

  end do

  i=jl+1
  vals(2)=( x-grid_x(i-1) )/(grid_x(i)-grid_x(i-1))
  vals(1)=( grid_x(i)-x )/(grid_x(i)-grid_x(i-1))
  inds(2)=i
  inds(1)=i-1

 end subroutine basefun
!*************************************************************************
!04oct15
 subroutine annualdata
 implicit none
 integer :: time_yr
 integer :: ntime_yr
 real(prec), dimension(:), allocatable:: y_yr(:), z_yr(:),a_yr(:),b_yr(:), &
    &   d_yr(:), c_yr(:), spread_yr(:), partdef_yr(:), tb_yr(:), RRbar_yr(:)
 CHARACTER(*), PARAMETER :: fileplace = "/data/home/tew158/partdef/v21/calibration/calib22mpi/simul/"
 ntime_yr=ntime/4
 allocate(y_yr(ntime_yr),z_yr(ntime_yr), &
    &     a_yr(ntime_yr),b_yr(ntime_yr), &
    &     d_yr(ntime_yr),c_yr(ntime_yr), &
    &     spread_yr(ntime_yr),partdef_yr(ntime_yr), &
    &     tb_yr(ntime_yr), &
    &     RRbar_yr(ntime_yr)       ) !10jan16

   time=1
   do time_yr=1, ntime_yr
    y_yr(time_yr)=sum(y(time:time+3)) !/4.0_prec
    z_yr(time_yr)=sum(z(time:time+3)) !/4.0_prec
    a_yr(time_yr)=sum(a(time:time+3)) !/4.0_prec
    b_yr(time_yr)=sum(b(time:time+3)) !/4.0_prec
    d_yr(time_yr)=sum(d(time:time+3)) !/4.0_prec
    c_yr(time_yr)=sum(c(time:time+3)) !/4.0_prec
    spread_yr(time_yr)=sum(spread(time:time+3))/4.0_prec
    if(a_yr(time_yr).gt.zero) then  !07mar16
     partdef_yr(time_yr)=d_yr(time_yr)/a_yr(time_yr)
    else
     partdef_yr(time_yr)=zero
    end if
    tb_yr(time_yr)=sum(tb(time:time+3)) !/4.0_prec
    RRbar_yr(time_yr)=sum(d(time:time+3)*RRbar(time:time+3)) &
        & /max(small,sum(d(time:time+3))) !10jan16
    time=time+4
   end do



    ntime=ntime_yr
    y(1:ntime)=y_yr(1:ntime)
    z(1:ntime)=z_yr(1:ntime)
    a(1:ntime)=a_yr(1:ntime)
    b(1:ntime)=b_yr(1:ntime)
    d(1:ntime)=d_yr(1:ntime)
    c(1:ntime)=c_yr(1:ntime)
    spread(1:ntime)=spread_yr(1:ntime)
    partdef(1:ntime)=partdef_yr(1:ntime)
    tb(1:ntime)=tb_yr(1:ntime)
    RRbar(1:ntime)=RRbar_yr(1:ntime) !10jan16

 IF(ID==0) THEN !10jan18
  open(42, file=fileplace//'simulpaths_yr.dat')
  !open (42, file='simulpaths_yr.dat')
    write(42,*) 'time, y,  z, a, b, d, R, c, spr '
    do time=1, min(5000,ntime) !18feb17
    if((time.ge.2000).and.(time.le.ntime)) write(42, & !13dec15
                    & '(i6,f10.6,f10.6,f10.6, &
                    & f10.6,f10.6, &
                    & f10.6, &
                    & f10.6,f10.6)') &
        & time, y(time),  z(time), a(time),  &
        & b(time), d(time), &
        & RRbar(time),  &        !16oct14
        & c(time), spread(time)                 !09jan14
    end do
  close(42)
 END IF

!!*    open(297, file='inc_t.dat')
!!*     do time=1, ntime
!!*        write(297,'(i6,f14.6,f14.6,i4)') time, inc_t(time), ui_t(time), emp_t(time)
!!*     end do
!!*    close(297)


 end subroutine annualdata



!*************************************************************************
!05oct15
 subroutine report_stats
 implicit none
 ! .. Statistics ..
 IF(ID==0) THEN !10jan18
    write(outfile1,*) '--------------------'
    write(outfile1,*) 'Summary statistics'
    write(outfile1,*) '--------------------'
    write(outfile1,*)
END IF

    y_aver=sum(y(1:ntime))/ntime
    logy_aver=sum(log(y(1:ntime)))/ntime
    logy_var=sum((log(y(1:ntime))-logy_aver)**(2.0_prec))/ntime
    logy_corr=(sum((( log(y(2:ntime)))-logy_aver)*((log(y(1:ntime-1)))-logy_aver))/real(ntime-1) )/ &
        & (logy_var)    !26may14
    z_aver=sum(z(1:ntime))/ntime
    logz_aver=sum(log(z(1:ntime)))/ntime
    logz_var=sum((log(z(1:ntime))-logz_aver)**(2.0_prec))/ntime
    logz_corr=(sum((( log(z(2:ntime)))-logz_aver)*((log(z(1:ntime-1)))-logz_aver))/real(ntime-1) )/ &
        & (logz_var)


    a_aver= sum(a(1:ntime))/ntime

    a_aver2=a_aver !20sep14

!    b_aver= sum(b(1:ntime),b(1:ntime).gt.zero)/count(b(1:ntime).gt.zero)
    b_aver= sum(b(1:ntime))/ntime
    d_aver= sum(d(1:ntime),d(1:ntime).gt.zero)/count(d(1:ntime).gt.zero)
    defrate=sum(d(1:ntime)/a(1:ntime),a(1:ntime).gt.zero)/count(d(1:ntime).gt.zero)

    cons_aver=sum(c(1:ntime))/ntime
    logc_aver=sum(log(c(1:ntime)))/ntime
    logc_var=sum((log(c(1:ntime))-logc_aver)**(2.0_prec))/ntime

 IF(ID==0) THEN !10jan18
    write(outfile1,*)
    write(outfile1,'(a25,f9.4)') 'Average inc ', y_aver
    write(outfile1,'(a25,f9.4)') 'Variance log inc ', logy_var
    write(outfile1,'(a25,f9.4)') 'Sd log inc ', sqrt(logy_var)
    write(outfile1,'(a25,f9.4)') 'Autocorr log inc ', logy_corr !26may15
    write(outfile1,*)
    write(outfile1,'(a25,f9.4)') 'Average z ', z_aver
    write(outfile1,'(a25,f9.4)') 'Variance log z ', logz_var
    write(outfile1,'(a25,f9.4)') 'Sd log z ', sqrt(logz_var)
    write(outfile1,'(a25,f9.4)') 'Autocorr log z ', logz_corr

    write(outfile1,*)
    write(outfile1,'(a25,f9.4)') 'Average A ', a_aver
    write(outfile1,*)
    write(outfile1,'(a25,f9.4)') 'Average B          ', b_aver
    write(outfile1,'(a25,f9.4)') 'Average D (if D>0) ', d_aver
    write(outfile1,'(a25,f9.4)') 'Aver def rate (if D>0) ', defrate
    write(outfile1,'(a25,f9.4)') 'Debt freq (A>0 ) ', real(count(a(1:ntime).gt.zero+small))/real(ntime)
        do jz=1, nz
    write(outfile1,'(a16,f9.4,f9.4)') 'for z= ', zj(jz), real(count((a(1:ntime).gt.zero+small) &
                                                        & .and.(abs(z(1:ntime)-zj(jz)).lt.small) )) &
                                                        & /real(count(abs(z(1:ntime)-zj(jz)).lt.small) )
        end do
                                                                                                       &
    write(outfile1,'(a25,f9.4)') 'Def freq (D>0 cond A>0) ',real(count(d(1:ntime).gt.zero+0.0001_prec))/real(count(a(1:ntime).gt.zero+0.0001_prec))
    write(outfile1,'(a25,f9.4)') 'Def freq (D=A cond A>0) ',real(count((d(1:ntime).ge.a(1:ntime)-small).and.(a(1:ntime).gt.zero+small))) &
                                                            &   /real(count(a(1:ntime).gt.zero+small))
        do jz=1, nz
    write(outfile1,'(a16,f9.4,f9.4)') 'for z= ', zj(jz),real(count((d(1:ntime).ge.a(1:ntime)-small) &
                                                        & .and.(a(1:ntime).gt.zero+small)&
                                                        & .and.(abs(z(1:ntime)-zj(jz)).lt.small) )) &
                                                        &   /real(count((a(1:ntime).gt.zero+small) &
                                                        & .and.(abs(z(1:ntime)-zj(jz)).lt.small)    ) )
        end do
    write(outfile1,'(a25,f9.4)') 'Def freq (D=A cond D>0) ',real(count((d(1:ntime).ge.a(1:ntime)-small).and.(d(1:ntime).gt.zero+small))) &
                                                            &   /real(count(d(1:ntime).gt.zero+small))
        do jz=1, nz
    write(outfile1,'(a16,f9.4,f9.4)') 'for z= ', zj(jz),real(count((d(1:ntime).ge.a(1:ntime)-small) &
                                                        & .and.(d(1:ntime).gt.zero+small)&
                                                        & .and.(abs(z(1:ntime)-zj(jz)).lt.small) )) &
                                                        &   /real(count((d(1:ntime).gt.zero+small) &
                                                        & .and.(abs(z(1:ntime)-zj(jz)).lt.small)    ) )
        end do

    write(outfile1,*)
    write(outfile1,'(a25,f9.4)') 'Average cons ', cons_aver
    write(outfile1,'(a25,f9.4)') 'Variance log cons ', logc_var

    write(outfile1,*)
    write(outfile1,*) ' Grids binding? '
    write(outfile1,'(a25,f12.8)') '% Bmin ', real(count(b(1:ntime).le.(Bj(1) +gridB_dist/two)))/real(ntime)
    write(outfile1,'(a25,f12.8)') '% Dmin ', real(count((d(1:ntime)/a(1:ntime)).le.((Dj(1)) +gridD_dist/two)))/real(ntime) !17apr14
    write(outfile1,'(a25,f12.8)') '% Amax ', real(count(a(1:ntime).ge.(Aj(nA)-gridA_dist/two)))/real(ntime)
    write(outfile1,'(a25,f12.8)') '% Bmax ', real(count(b(1:ntime).ge.(Bj(nB)-gridB_dist/two)))/real(ntime)
    write(outfile1,'(a25,f12.8)') '% Dmax ', real(count(d(1:ntime).ge.((Dj(nD))-gridD_dist/two)))/real(ntime)
    write(outfile1,'(a25,f12.8)') '% Dmax (if D>0)', real(count((d(1:ntime)/a(1:ntime)).ge.((Dj(nD))-gridD_dist/two)))/real(count(d(1:ntime).gt.zero)) !17apr14
    write(outfile1,'(a25,i12)') 'states noconv 0.0001 q ', noconv !25mar13

    write(outfile1,*)
    write(outfile1,*) ' Max and min realised: '
    write(outfile1,'(a25,f12.8)') 'Amin ', minval(a(1:ntime))
    write(outfile1,'(a25,f12.8)') 'Amax ', maxval(a(1:ntime))
    write(outfile1,'(a25,f12.8)') 'Bmin ', minval(b(1:ntime))
    write(outfile1,'(a25,f12.8)') 'Bmax ', maxval(b(1:ntime))
    write(outfile1,'(a25,f12.8)') 'Dmin ', minval(d(1:ntime))
    write(outfile1,'(a25,f12.8)') 'Dmax ', maxval(d(1:ntime))


!09apr13
    write(outfile1,*) '--------------------'
    write(outfile1,*) 'MAIN AVERAGES '
    write(outfile1,*) '--------------------'
    write(outfile1,*)

    write(outfile1,*)
    write(outfile1,*) 'DEFAULT  '
    write(outfile1,'(a25,f9.4)') 'Prob(D>0         ) ',real(count(d(1:ntime).gt.zero+small))/real(ntime)
END IF
    freqdef=real(count(d(1:ntime).gt.zero+small))/real(ntime)
IF(ID==0) THEN !10jan18
    write(outfile1,'(a25,f9.4)') 'Prob(D>0 cond A>0) ',real(count(d(1:ntime).gt.zero+small))/real(count(a(1:ntime).gt.zero+small))
    write(outfile1,'(a25,f9.4)') 'Prob(D=A cond D>0) ',real(count((d(1:ntime).ge.a(1:ntime)-small).and.(d(1:ntime).gt.zero+small))) &
                                                            &   /real(count(d(1:ntime).gt.zero+small))
    write(outfile1,'(a25,f9.4)') 'D/A cond  A>0 ', sum(d(1:ntime)/a(1:ntime),a(1:ntime).gt.zero+small)/real(count(a(1:ntime).gt.zero+small))
    write(outfile1,'(a25,f9.4)') 'D/A cond  D>0 ', sum(d(1:ntime)/a(1:ntime),d(1:ntime).gt.zero+small)/real(count(d(1:ntime).gt.zero+small))
END IF
    arrears=sum(d(1:ntime)/a(1:ntime),d(1:ntime).gt.zero+small)/real(count(d(1:ntime).gt.zero+small)) !24sep13
IF(ID==0) THEN !10jan18
    write(outfile1,'(a25,f9.4)') 'D/A cond  R=1 ', &
            sum(d(1:ntime)/a(1:ntime),tR(1:ntime).eq.1)/real(count(tR(1:ntime).eq.1)) !28mar14

!02oct13
    write(outfile1,'(a25,f9.4)') 'D/Y cond  D>0 ', sum(d(1:ntime)/y(1:ntime),d(1:ntime).gt.zero+small)/real(count(d(1:ntime).gt.zero+small))


!09jan14
    write(outfile1,*) 'RENEGOTIATION  '
    write(outfile1,'(a25,f9.4)') 'Sample freq(R=1 cond D>0) ', &
        & sum(real(tR(1:ntime)),count(d(1:ntime).gt.zero+small))/ &
        &   real(count(d(1:ntime).gt.zero+small))
    write(outfile1,'(a25,f9.4)') 'Prob(R cond D>0) ', &
        & sum(trr(1:ntime),count(d(1:ntime).gt.zero+small))/ &
        &   real(count(d(1:ntime).gt.zero+small))
    write(outfile1,'(a25,f9.4)') 'AR/A cond  R=1 ', &
                            &   (sum(tAr(1:ntime),tR(1:ntime).eq.1)/real(count(tR(1:ntime).eq.1)))/ &
                            &    (sum(a(1:ntime),tR(1:ntime).eq.1)/real(count(tR(1:ntime).eq.1)))
    write(outfile1,'(a25,f9.4)') 'AR/A cond  Prob R>0 ', &
                            &   (sum(tAr(1:ntime),trr(1:ntime).gt.zero+small)/real(count(trr(1:ntime).gt.zero+small)))/ &
                            &    (sum(a(1:ntime),trr(1:ntime).gt.zero+small)/real(count(trr(1:ntime).gt.zero+small)))



!    write(outfile1,*)
    write(outfile1,*) ' COUPON   '
    write(outfile1,'(a25,f9.4)') 'A/Y         ', (sum(a(1:ntime))/real(ntime))/(sum(y(1:ntime))/real(ntime))
END IF
    AtoY=sum(a(1:ntime)/y(1:ntime))/real(ntime) !23jun17 (sum(a(1:ntime))/real(ntime))/(sum(y(1:ntime))/real(ntime))

 IF(ID==0) THEN !10jan18
    write(outfile1,'(a25,f9.4)') 'A/Y cond  A>0 ', (sum(a(1:ntime),a(1:ntime).gt.zero+small)/real(count(a(1:ntime).gt.zero+small)))/ &
                                            &    (sum(y(1:ntime))/real(ntime))
    write(outfile1,'(a25,f9.4)') 'A/Y cond  D>0 ', (sum(a(1:ntime),d(1:ntime).gt.zero+small)/real(count(d(1:ntime).gt.zero+small)))/ &
                                            &    (sum(y(1:ntime))/real(ntime))
!24jun13
    write(outfile1,'(a25,f9.4)') 'A/Y cond  D=A ', (sum(a(1:ntime),(d(1:ntime).ge.a(1:ntime)-small).and.d(1:ntime).gt.zero+small))/ &
                                            &    real(count((d(1:ntime).ge.a(1:ntime)-small).and.(d(1:ntime).gt.zero+small)))/ &
                                            &    (sum(y(1:ntime))/real(ntime))

!09jan14
    write(outfile1,'(a25,f9.4)') 'A/Y cond  Prob R>0 ',  ((sum(a(1:ntime),(trr(1:ntime).gt.zero+small))/ &
                                            &    real(count((trr(1:ntime).gt.zero+small))))  )/ &
                                            &    (sum(y(1:ntime))/real(ntime))
    write(outfile1,'(a25,f9.4)') 'A/Y cond  R=1 ',  ((sum(a(1:ntime),(tR(1:ntime).eq.1))/ &
                                            &    real(count((tR(1:ntime).eq.1))))  )/ &
                                            &    (sum(y(1:ntime))/real(ntime))

!04aug13
    write(outfile1,*) ' DEBT   '
    write(outfile1,'(a25,f9.4)') 'NOMINAL DEBT/Y         ', ((sum(a(1:ntime))/real(ntime))/(sum(y(1:ntime))/real(ntime)))/(one-delta)
    write(outfile1,'(a25,f9.4)') 'DISCOUNTED DEBT/Y      ', ((sum(a(1:ntime))/real(ntime))/(sum(y(1:ntime))/real(ntime)))/(one-q0*delta)

!    write(outfile1,*)
    write(outfile1,*) 'BORROWING/SAVING  '
    write(outfile1,'(a25,f9.4)') 'B/Y         ', (sum(b(1:ntime))/real(ntime))/(sum(y(1:ntime))/real(ntime))
    write(outfile1,'(a25,f9.4)') 'B/Y cond  A>0 ', (sum(b(1:ntime),a(1:ntime).gt.zero+small)/real(count(a(1:ntime).gt.zero+small)))/ &
                                            &    (sum(y(1:ntime))/real(ntime))
    write(outfile1,'(a25,f9.4)') 'B/Y cond  D>0 ', (sum(b(1:ntime),d(1:ntime).gt.zero+small)/real(count(d(1:ntime).gt.zero+small)))/ &
                                            &    (sum(y(1:ntime))/real(ntime))

!24jun13
    write(outfile1,'(a25,f9.4)') 'B/Y cond  D=A ', (sum(b(1:ntime),(d(1:ntime).ge.a(1:ntime)-small).and.(d(1:ntime).gt.zero+small))/ &
                                            &   real(count((d(1:ntime).ge.a(1:ntime)-small).and.(d(1:ntime).gt.zero+small))))/ &
                                            &    (sum(y(1:ntime))/real(ntime))
    write(outfile1,'(a25,f9.4)') 'Prob(B>0 cond D>0) ',real(count((b(1:ntime).ge.zero+small).and.(d(1:ntime).gt.zero+small))) &
                                                            &   /real(count(d(1:ntime).gt.zero+small))
    write(outfile1,'(a25,f9.4)') 'Prob(B>0 cond D=A) ',real(count((b(1:ntime).ge.zero+small).and.(d(1:ntime).ge.a(1:ntime)-small).and.(d(1:ntime).gt.zero+small))) &
                                                            &   /real(count((d(1:ntime).ge.a(1:ntime)-small).and.(d(1:ntime).gt.zero+small)) )
    write(outfile1,'(a25,f9.4)') 'B/Y cond  R=1 ', (sum(b(1:ntime),tR(1:ntime).eq.1)/real(count(tR(1:ntime).eq.1)))/ &
                                            &    (sum(y(1:ntime))/real(ntime)) !28mar14

!    write(outfile1,*)
    write(outfile1,*) 'TRADE BALANCE  '
    write(outfile1,'(a25,f9.4)') 'T/Y         ', (sum(tb(1:ntime))/real(ntime))/(sum(y(1:ntime))/real(ntime))
    write(outfile1,'(a25,f9.4)') 'T/Y cond  A>0 ', (sum(tb(1:ntime),a(1:ntime).gt.zero+small)/real(count(a(1:ntime).gt.zero+small)))/ &
                                            &    (sum(y(1:ntime))/real(ntime))
    write(outfile1,'(a25,f9.4)') 'T/Y cond  D>0 ', (sum(tb(1:ntime),d(1:ntime).gt.zero+small)/real(count(d(1:ntime).gt.zero+small)))/ &
                                            &    (sum(y(1:ntime))/real(ntime))

!    write(outfile1,*)
    write(outfile1,*) 'CONSUMPTION  '
    write(outfile1,'(a25,f9.4)') 'C/Y         ', (sum(c(1:ntime))/real(ntime))/(sum(y(1:ntime))/real(ntime))
    write(outfile1,'(a25,f9.4)') 'C/Y cond  A>0 ', (sum(c(1:ntime),a(1:ntime).gt.zero+small)/real(count(a(1:ntime).gt.zero+small)))/ &
                                            &    (sum(y(1:ntime))/real(ntime))
    write(outfile1,'(a25,f9.4)') 'C/Y cond  D>0 ', (sum(c(1:ntime),d(1:ntime).gt.zero+small)/real(count(d(1:ntime).gt.zero+small)))/ &
                                            &    (sum(y(1:ntime))/real(ntime))

!    write(outfile1,*)
    write(outfile1,*) 'OUTPUT  '
    write(outfile1,'(a25,f9.4)') 'Y/averY cond  A>0 ', (sum(y(1:ntime),a(1:ntime).gt.zero+small)/real(count(a(1:ntime).gt.zero+small)))/ &
                                            &    (sum(y(1:ntime))/real(ntime))
    write(outfile1,'(a25,f9.4)') 'Y/averY cond  D>0 ', (sum(y(1:ntime),d(1:ntime).gt.zero+small)/real(count(d(1:ntime).gt.zero+small)))/ &
                                            &    (sum(y(1:ntime))/real(ntime))
    write(outfile1,'(a25,f9.4)') 'Y/averY cond  R=1 ', (sum(y(1:ntime),tR(1:ntime).eq.1)/real(count(tR(1:ntime).eq.1)))/ &
                                            &    (sum(y(1:ntime))/real(ntime)) !28mar14
!    write(outfile1,*)
    write(outfile1,*) 'SPREAD  '
    write(outfile1,'(a25,f9.4)') 'spread         ', (sum(spread(1:ntime))/real(ntime))
END IF

    Spr=(sum(spread(1:ntime))/real(ntime))
    qqaver=(sum(q(1:ntime)))/real(ntime)

 IF(ID==0) THEN !10jan18
    write(outfile1,'(a25,f9.4)') 'spread cond  A>0 ', (sum(spread(1:ntime),a(1:ntime).gt.zero+small)/real(count(a(1:ntime).gt.zero+small)))
    write(outfile1,'(a25,f9.4)') 'spread cond  B>0 ', (sum(spread(1:ntime),b(1:ntime).gt.zero+small)/real(count(b(1:ntime).gt.zero+small)))
    write(outfile1,'(a25,f9.4)') 'spread cond  D>0 ', (sum(spread(1:ntime),(d(1:ntime).gt.zero+small)) &
                                        & /real(count((d(1:ntime).gt.zero+small))))
    write(outfile1,'(a25,f9.4)') 'spread cond  D>0 B>0 ', (sum(spread(1:ntime),(d(1:ntime).gt.zero+small).and.(b(1:ntime).gt.zero+small)) &
                                        & /real(count((d(1:ntime).gt.zero+small).and.(b(1:ntime).gt.zero+small)))) !04aug13
    write(outfile1,'(a25,f9.4)') 'spread cond  R=1 B>0 ', (sum(spread(1:ntime),(tR(1:ntime).eq.1).and.(b(1:ntime).gt.zero+small)) &
                                        & /real(count((tR(1:ntime).eq.1).and.(b(1:ntime).gt.zero+small)))) !28mar14



    write(outfile1,*) '--------------------'
    write(outfile1,*) 'BUSINES CYCLES '
    write(outfile1,*) '--------------------'
    write(outfile1,*)

    write(outfile1,'(a25,a9,a9,a9)') '        ', 'stdv ', 'corr y '
END IF

    ! .. output ..
    logy_aver=sum(log(y(1:ntime)))/real(ntime)
    logy_stdv=sqrt(sum((log(y(1:ntime))-logy_aver)*(log(y(1:ntime))-logy_aver))/real(ntime))
    corrx= (sum((log(y(1:ntime))-logx_aver)*(log(y(1:ntime))-logy_aver))/real(ntime) )/(logy_stdv*logy_stdv)

 IF(ID==0)   write(outfile1,'(a25,f9.4,f9.4)') 'income   ', logy_stdv/logy_stdv, corrx   !10jan18

    ! .. consumption ..
    logx_aver=sum(log(c(1:ntime)))/ntime
    logx_stdv=sqrt(sum((log(c(1:ntime))-logx_aver)*(log(c(1:ntime))-logx_aver))/real(ntime))
    corrx=   (sum((log(c(1:ntime))-logx_aver)*(log(y(1:ntime))-logy_aver))/real(ntime))/(logx_stdv*logy_stdv)
    IF(ID==0) write(outfile1,'(a25,f9.4,f9.4)') 'cons   ', logx_stdv/logy_stdv, corrx
    sdC=logx_stdv/logy_stdv
    corrC=corrx

    ! .. trade (as proport of Y)..
    logx_aver=sum((tb(1:ntime)/y(1:ntime)))/real(ntime)
    logx_stdv=sqrt(sum(((tb(1:ntime)/y(1:ntime))-logx_aver)*((tb(1:ntime)/y(1:ntime))-logx_aver))/real(ntime))
    corrx=   (sum(((tb(1:ntime)/y(1:ntime))-logx_aver)*(log(y(1:ntime))-logy_aver))/real(ntime))/(logx_stdv*logy_stdv)
    IF(ID==0) write(outfile1,'(a25,f9.4,f9.4)') 'trade balance  ', logx_stdv/logy_stdv, corrx
    sdEX=logx_stdv/logy_stdv !24sep13
    corrEX=corrx

    ! .. spread ..
    logx_aver=sum((spread(1:ntime)))/real(ntime)
    logx_stdv=sqrt(sum(((spread(1:ntime))-logx_aver)*((spread(1:ntime))-logx_aver))/real(ntime))
    corrx=  ( sum(((spread(1:ntime))-logx_aver)*(log(y(1:ntime))-logy_aver))/real(ntime))/(logx_stdv*logy_stdv)
    IF(ID==0) write(outfile1,'(a25,f9.4,f9.4)') 'spread  ', logx_stdv, corrx
    sdSpr=logx_stdv
    corrSpr=corrx

!02oct13
    spr_aver=sum(spread(1:ntime))/real(ntime)
    spr_stdv=sqrt(sum((spread(1:ntime)-spr_aver)*(spread(1:ntime)-spr_aver))/real(ntime))

    tb_aver=sum(((tb(1:ntime)/y(1:ntime)))/real(ntime))
    tb_stdv=sqrt(sum(((tb(1:ntime)/y(1:ntime))-tb_aver)*((tb(1:ntime)/y(1:ntime))-tb_aver))/real(ntime))
    corr_sprtb=  ( sum(((spread(1:ntime))-spr_aver)*(tb(1:ntime)/y(1:ntime)-tb_aver))/real(ntime))/(spr_stdv*tb_stdv)

 IF(ID==0)     write(outfile1,'(a25,f9.4)') 'corr spr tb  ', corr_sprtb !10jan18

!02oct13
    ! .. part default ..
    d_aver=sum(d(1:ntime),d(1:ntime).gt.zero+small)/real(count(d(1:ntime).gt.zero+small))
    d_stdv=sqrt(sum(((d(1:ntime)-d_aver)*(d(1:ntime)-d_aver)),d(1:ntime).gt.zero+small)&
        & /real(count(d(1:ntime).gt.zero+small)))


    logy_aver=sum(log(y(1:ntime)),d(1:ntime).gt.zero+small)/real(count(d(1:ntime).gt.zero+small))
    logy_stdv=sqrt(sum((log(y(1:ntime))-logy_aver)*(log(y(1:ntime))-logy_aver),d(1:ntime).gt.zero+small)/real(count(d(1:ntime).gt.zero+small)))
    corr_dy=  ( sum(((d(1:ntime))-d_aver)*(log(y(1:ntime))-logy_aver),d(1:ntime).gt.zero+small)/real(count(d(1:ntime).gt.zero+small)))/(d_stdv*logy_stdv)

 IF(ID==0)     write(outfile1,'(a25,f9.4,f9.4)') 'default  ', d_stdv, corr_dy  !10jan18


    tb_aver=sum((tb(1:ntime)/y(1:ntime)),d(1:ntime).gt.zero+small)/real(count(d(1:ntime).gt.zero+small))
    tb_stdv=sqrt(sum(((tb(1:ntime)/y(1:ntime))-tb_aver)*((tb(1:ntime)/y(1:ntime))-tb_aver),d(1:ntime).gt.zero+small)/real(count(d(1:ntime).gt.zero+small)))
    corr_dtb=  ( sum(((d(1:ntime))-d_aver)*(tb(1:ntime)/y(1:ntime)-tb_aver),d(1:ntime).gt.zero+small)/real(count(d(1:ntime).gt.zero+small)))/(d_stdv*tb_stdv)

IF(ID==0) THEN !10jan18
    write(outfile1,'(a25,f9.4)') 'stdv partdef ', d_stdv
    write(outfile1,'(a25,f9.4)') 'corr d logy  ', corr_dy
    write(outfile1,'(a25,f9.4)') 'corr d tb  ', corr_dtb
END IF

    d_aver=sum(d(1:ntime),(b(1:ntime).gt.zero+small).and.(d(1:ntime).gt.zero+small))/ &
         & real(count((b(1:ntime).gt.zero+small).and.(d(1:ntime).gt.zero+small)))
    d_stdv=sqrt(sum(((d(1:ntime)-d_aver)*(d(1:ntime)-d_aver)),((b(1:ntime).gt.zero+small).and.(d(1:ntime).gt.zero+small)))&
        & /real(count(((b(1:ntime).gt.zero+small).and.(d(1:ntime).gt.zero+small)))))
    spr_aver=sum(spread(1:ntime),((b(1:ntime).gt.zero+small).and.(d(1:ntime).gt.zero+small)))/ &
            & real(count(((b(1:ntime).gt.zero+small).and.(d(1:ntime).gt.zero+small))))
    spr_stdv=sqrt(sum((spread(1:ntime)-spr_aver)*(spread(1:ntime)-spr_aver),(b(1:ntime).gt.zero+small).and.(d(1:ntime).gt.zero+small))/ &
            & real(count(((b(1:ntime).gt.zero+small).and.(d(1:ntime).gt.zero+small)))))
    corr_dspr=  ( sum(((d(1:ntime))-d_aver)*(spread(1:ntime)-spr_aver),(b(1:ntime).gt.zero+small).and.(d(1:ntime).gt.zero+small))/ &
            & real(count((((b(1:ntime).gt.zero+small).and.(d(1:ntime).gt.zero+small))))) )/(d_stdv*spr_stdv)

 IF(ID==0)    write(outfile1,'(a25,f9.4)') 'corr d spr  ', corr_dspr  !10jan18



!05aug13mn
!16oct14
!!*    write(outfile1,*)
!!*    write(outfile1,*) '--------------------'
!!*    write(outfile1,*) 'COMPARATIVE STATICS '
!!*    write(outfile1,*) '--------------------'
!!*    write(outfile1,'(4a6,a6,4a6,a2,8a8)')  'beta', 'del', 'Rbar', 'psi0','jstar','phi1','gam','upD','minPsi','¦', &
!!*                                      & 'A/Y', 'Spr', 'sdSpr','sdC','freqdef','corrSpr','corrC','corrX'
!!*    write(outfile1,'(f6.3,f6.3,f6.3,f6.3,i6,f6.3,f6.3,f6.3,f6.3,a2,8f8.4)') beta, delta, Rbar, psi0(1), &
!!*                                    & jzstar, phi1, &
!!*                                    & gamma_psi, upperdef, Psimin, &
!!*                                    & '¦', &
!!*                                    & AtoY, Spr, sdSpr, sdC, freqdef, corrSpr, corrC, corrEX


IF(ID==0) THEN !10jan18
!24sep13
    write(outfile1,*)
    write(outfile1,*) '--------------------'
    write(outfile1,*) 'SPECIFIC CALIBRATION TARGETS '
    write(outfile1,*) '--------------------'

    !write(outfile1,'(a6,f6.3)')
    write(outfile1,*) 'write other parameters '
    write(outfile1,'(a5,f6.3,a3,i3,a4,i3)') 'dist=',gridA_dist, 'n=', nA,'ny=', ny
    write(outfile1,'(a9,f8.5,a9,i2,a9,f8.5)') 'voldtol=', voldtol, 'finiteec=', finiteec, 'speedq=', speed_adjq
    write(outfile1,'(a5,f6.3,a5,f6.3)') 'int=', (1.0/q0)-1, 'sig=', sigma
!!*    if(nR.ne.2) then    !16oct14
!!*     write(*,*) ' nR is not 2!! Must change writing out '
!!*     stop
!!*    end if
    write(outfile1,'(a10,f6.3,a5,f6.3)') 'Rbar_aver=', Rbar_aver, 'del=', delta !16oct14
    write(outfile1,*) 'piR=', piR !16oct14

    write(outfile1,*)
    write(outfile1,'(5a6,a7,a7,a2,5a8)')  'beta', 'psi0','jstar','phi1','gam','upD','minPsi','¦', &
                                      & 'A/Y', 'freqdef','sdEX', 'arrears', 'spread'
    write(outfile1,'(f6.3,f6.3,i6,f6.3,f6.3,f7.3,f7.3,a2,5f8.4)') &
                                    & beta, psi0(1),jzstar, phi1,gamma_psi, upperdef, Psimin, &
                                    & '¦', &
                                    & AtoY, freqdef, sdEX, arrears, Spr


!07mar14
    write(outfile1,*)
    write(outfile1,*) '--------------------'
    write(outfile1,*) 'TABLE MAIN RESULTS '
    write(outfile1,*) '--------------------'
   write(outfile1,*)
   write(outfile1,*) ' .. MEANS | arrears >0 .. '
   write(outfile1,'(a30,a10,f9.5)') 'partial default', '(D/A)', arrears
   write(outfile1,'(a30,a10,f9.5)') 'debt due/output', '(A/Y)', &
                & (sum(a(1:ntime)/y(1:ntime),d(1:ntime).gt.zero+small)/real(count(d(1:ntime).gt.zero+small)))
   write(outfile1,'(a30,a10,f9.5)') 'new loans/output B>0', '(qB/Y)', &
                &  (sum(q(1:ntime)*b(1:ntime)/y(1:ntime), &
                &   (d(1:ntime).gt.zero+small).and.(b(1:ntime).gt.zero+small)) &
                &   /real(count((d(1:ntime).gt.zero+small).and.(b(1:ntime).gt.zero+small))) )
   write(outfile1,'(a30,a10,f9.5)') 'new loans/output' , '(qB/Y)', &
                &  (sum(q(1:ntime)*b(1:ntime)/y(1:ntime), &
                &   d(1:ntime).gt.zero+small)/real(count(d(1:ntime).gt.zero+small)))
!   write(outfile1,'(a30,a10,f9.5)') 'spread B>0', ' ', (sum(spread(1:ntime), &
!                & (d(1:ntime).gt.zero+small).and.(b(1:ntime).gt.zero+small)) &
!                & /real(count((d(1:ntime).gt.zero+small).and.(b(1:ntime).gt.zero+small))))
   write(outfile1,'(a30,a10,f9.5)') 'spread ', ' ', (sum(spread(1:ntime), &
                & (d(1:ntime).gt.zero+small)) &
                & /real(count((d(1:ntime).gt.zero+small))))
   write(outfile1,'(a30,a10,f9.5)') 'coupons def/output' , '(D/Y)', sum(d(1:ntime)/y(1:ntime), &
                & d(1:ntime).gt.zero+small)/real(count(d(1:ntime).gt.zero+small))
   write(outfile1,'(a30,a10,f9.5)') 'debt service/output' , ' ', sum((a(1:ntime)-d(1:ntime))/y(1:ntime), &
                & d(1:ntime).gt.zero+small)/real(count(d(1:ntime).gt.zero+small))
   write(outfile1,'(a30,a10,f9.5)') 'debt/output' , ' ', &      !16jan15
                & (sum(a(1:ntime)/y(1:ntime),d(1:ntime).gt.zero+small) &
                &       /real(count(d(1:ntime).gt.zero+small)))/((one-q0*delta)*modelfreq)
!                & ((sum(a(1:ntime),d(1:ntime).gt.zero+small)/real(count(d(1:ntime).gt.zero+small)))/ &
!                &   (sum(y(1:ntime),d(1:ntime).gt.zero+small)/real(count(d(1:ntime).gt.zero+small))))/((one-q0*delta)*modelfreq)

   write(outfile1,*)
   write(outfile1,*) ' .. MEANS OVERALL .. '
   write(outfile1,'(a30,a10,f9.5)') 'freq arrears>0', '  ', freqdef
   write(outfile1,'(a30,a10,f9.5)') 'debt due/output', 'A/Y', (sum(a(1:ntime)/y(1:ntime))/real(ntime))
   write(outfile1,'(a30,a10,f9.5)') 'new loans/output B>0', '(qB/Y)', &
                &  (sum(q(1:ntime)*b(1:ntime)/y(1:ntime), &
                &   (b(1:ntime).gt.zero+small)) &
                &   /real(count((b(1:ntime).gt.zero+small))) )
   write(outfile1,'(a30,a10,f9.5)') 'new loans/output' , '(qB/Y)', &
                &  (sum(q(1:ntime)*b(1:ntime)/y(1:ntime))/real(ntime))
!   write(outfile1,'(a30,a10,f9.5)') 'spread B>0', ' ', (sum(spread(1:ntime), &
!                & (b(1:ntime).gt.zero+small)) &
!                & /real(count((b(1:ntime).gt.zero+small))))
!   write(outfile1,'(a30,a10,f9.5)') 'spread ', ' ', (sum(spread(1:ntime) &
!                & ) &
!                & /real(ntime))
   write(outfile1,'(a30,a10,f9.5)') 'spread |apr>0', ' ', (sum(spread(1:ntime-1), &
                & a(2:ntime).ge.small) &
                & /real(count(a(2:ntime).ge.small)))
   write(outfile1,'(a30,a10,f9.5)') 'coupons def/output' , '(D/Y)', &
                & sum(d(1:ntime)/y(1:ntime)) /real(ntime) !23jun17
   write(outfile1,'(a30,a10,f9.5)') 'debt service/output' , ' ', sum((a(1:ntime)-d(1:ntime))/y(1:ntime) &
                & ) /real(ntime)
   write(outfile1,'(a30,a10,f9.5)') 'debt/output' , ' ', &      !16jan15
                & (sum(a(1:ntime)/y(1:ntime)) &
                &       /real(ntime))/((one-q0*delta)*modelfreq) !23jun17
!                & ((sum(a(1:ntime))/real(ntime))/(sum(y(1:ntime))/real(ntime)))/((one-q0*delta)*modelfreq)





   write(outfile1,*)
   write(outfile1,*) ' .. BUSINESS CYCLES .. '
   write(outfile1,'(a30,a10,f9.5)') 'sd C/Y', '  ',        sdC
   write(outfile1,'(a30,a10,f9.5)') 'sd exports/Y', '  ',  sdEX
   write(outfile1,'(a30,a10,f9.5)') 'sd spread', '  ',     sdSpr
   write(outfile1,'(a30,a10,f9.5)') 'sd default', '  ',    d_stdv
   write(outfile1,*)
   write(outfile1,'(a30,a10,f9.5)') 'corr y spread', '  ',          corrSpr
   write(outfile1,'(a30,a10,f9.5)') 'corr exports spread', '  ',    corr_sprtb
   write(outfile1,'(a30,a10,f9.5)') 'corr default spread', '  ',   corr_dspr


!15oct14
   write(outfile1,*)
   write(outfile1,*) ' .. BUSINESS CYCLES (oct 2014) .. '
END IF

    d_aver=sum(partdef(1:ntime),d(1:ntime).gt.zero+small)/ &
        & real(count((d(1:ntime).gt.zero+small)))
    d_stdv=sqrt(sum(((partdef(1:ntime)-d_aver)*(partdef(1:ntime)-d_aver)),((d(1:ntime).gt.zero+small)))&
        & /real(count(((d(1:ntime).gt.zero+small)))))
    spr_aver=sum(spread(1:ntime),d(1:ntime).gt.zero+small)/ &
        & real(count(d(1:ntime).gt.zero+small))
    spr_stdv=sqrt(sum((spread(1:ntime)-spr_aver)*(spread(1:ntime)-spr_aver),d(1:ntime).gt.zero+small) &
        & /real(count(((d(1:ntime).gt.zero+small)))))
    coupdef_cond=sum(d(1:ntime)/y(1:ntime), &
                & d(1:ntime).gt.zero+small)/real(count(d(1:ntime).gt.zero+small)) !10feb21
    coupdef_cond_sd=sqrt(sum(((d(1:ntime))/y(1:ntime)-coupdef_cond) &                  !10feb21
        &                   *((d(1:ntime))/y(1:ntime)-coupdef_cond), &
        &           d(1:ntime).gt.zero+small)   &
        &     /real(count(d(1:ntime).gt.zero+small)) )


 IF(ID==0) THEN !10jan18
   write(outfile1,*) 'DISPERSION D>0: '
   write(outfile1,'(a30,a10,f9.5)') 'sd part default', '  ',    d_stdv
   write(outfile1,'(a30,a10,f9.5)') 'sd spread', '  ',    spr_stdv
!   write(outfile1,'(a30,a10,f9.5)') 'sd C/sd Y', '  ',        sdC
   write(outfile1,'(a30,a10,f9.5)') 'sd coupon def/Y', '  ', coupdef_cond_sd
END IF

   ! ...................................................................
    d_aver=sum(partdef(1:ntime))/real(ntime)
    d_stdv_noncond =sqrt(sum((partdef(1:ntime)-d_aver)*(partdef(1:ntime)-d_aver))/real(ntime))
!    spr_aver=sum(spread(1:ntime))/real(ntime)
!    spr_stdv=sqrt(sum((spread(1:ntime)-spr_aver)*(spread(1:ntime)-spr_aver))/real(ntime))
    spr_aver=sum(spread(1:ntime-1),a(2:ntime).ge.small)/real(count(a(2:ntime).ge.small))
    spr_stdv=sqrt(sum((spread(1:ntime-1)-spr_aver)*(spread(1:ntime-1)-spr_aver), &
            & a(2:ntime).ge.small)/real(count(a(2:ntime).ge.small)))
    logy_aver=sum(log(y(1:ntime)))/real(ntime)
    logy_stdv=sqrt(sum((log(y(1:ntime))-logy_aver)*(log(y(1:ntime))-logy_aver))/real(ntime))
    tb_aver=sum((tb(1:ntime)/y(1:ntime)))/real(ntime) !17oct14
    tb_stdv=sqrt(sum(((tb(1:ntime)/y(1:ntime))-tb_aver)*((tb(1:ntime)/y(1:ntime))-tb_aver))/real(ntime)) !17oct14

!10feb21
    debtserv=sum((a(1:ntime)-d(1:ntime))/y(1:ntime))/real(ntime)
    debtserv_sd=sqrt(sum(((a(1:ntime)-d(1:ntime))/y(1:ntime)-debtserv) &
        &               *((a(1:ntime)-d(1:ntime))/y(1:ntime)-debtserv)) &
        &                   /real(ntime))
    coupdef=sum(d(1:ntime)/y(1:ntime))/real(ntime)
    coupdef_sd=sqrt(sum(((d(1:ntime))/y(1:ntime)-coupdef) &
        &               *((d(1:ntime))/y(1:ntime)-coupdef)) &
        &                   /real(ntime))

 IF(ID==0) THEN !10jan18
   write(outfile1,*) 'DISPERSION Overall D : '
   write(outfile1,'(a30,a10,f9.5)') 'sd part default', '  ',    d_stdv_noncond
   write(outfile1,'(a30,a10,f9.5)') 'sd spread', '  ',    spr_stdv
   write(outfile1,'(a30,a10,f9.5)') 'sd C/sd logy', '  ',        sdC
   write(outfile1,'(a30,a10,f9.5)') 'sd exports/Y /sd logy', '  ',  sdEX
END IF
!14feb17 - sd debt due to ouput
   debtdue=(sum(a(1:ntime)/y(1:ntime))/real(ntime))
   debtdue_stdv=sqrt(sum((a(1:ntime)/y(1:ntime)-debtdue)*(a(1:ntime)/y(1:ntime)-debtdue))/real(ntime))
   debt_stdv= debtdue_stdv/((one-q0*delta)*modelfreq)
 IF(ID==0) THEN !10jan18
   write(outfile1,'(a30,a10,f9.5)') 'sd debt due/output', '  ',    debtdue_stdv
   write(outfile1,'(a30,a10,f9.5)') 'sd debt /output', '  ',    &
    & debtdue_stdv/((one-q0*delta)*modelfreq) !14jun17
   write(outfile1,'(a30,a10,f9.5)') 'sd coupon def/Y', '  ', coupdef_sd !10feb21
   write(outfile1,'(a30,a10,f9.5)') 'sd debt service', '  ', debtserv_sd !10feb21
END IF

    corr_dspr=  ( sum(((partdef(1:ntime))-d_aver)*(spread(1:ntime)-spr_aver))/ &
            & real(ntime) )/(d_stdv_noncond*spr_stdv)
    corr_dy=  ( sum(((partdef(1:ntime))-d_aver)*(log(y(1:ntime))-logy_aver))/ &
            & real(ntime))/(d_stdv_noncond*logy_stdv)
    corr_tby=  ( sum((tb(1:ntime)/y(1:ntime)-tb_aver)*(log(y(1:ntime))-logy_aver))/ &
            & real(ntime))/(tb_stdv*logy_stdv)

    corr_ddebttoY=( sum(((partdef(1:ntime))-d_aver)*((a(1:ntime)/y(1:ntime))-debtdue))/ &
            & real(ntime) )/(d_stdv_noncond*debtdue_stdv)

 IF(ID==0) THEN !10jan18
   write(outfile1,*) 'CORRELATIONS Overall D : '

   write(outfile1,'(a30,a10,f9.5)') 'corr partdefault spread', '  ',   corr_dspr
   write(outfile1,'(a30,a10,f9.5)') 'corr y spread', '  ',          corrSpr
   write(outfile1,'(a30,a10,f9.5)') 'corr exports spread', '  ',    corr_sprtb
   write(outfile1,'(a30,a10,f9.5)') 'corr partdefault logy', '  ',   corr_dy
   write(outfile1,'(a30,a10,f9.5)') 'corr exports/y logy', '  ',    corr_tby
   write(outfile1,'(a30,a10,f9.5)') 'corr partdefault debttoY', '  ',   corr_ddebttoY

   write(outfile1,'(a30,a10,f9.5)') 'corr spread debttoY', '  ', &
        & ( sum(((spread(1:ntime))-spr_aver)*((a(1:ntime)/y(1:ntime))-debtdue))/ &
        &   real(ntime) )/(spr_stdv*debtdue_stdv)   !14jun17
! ----------------------------------------------------------------------------
!03oct15
    write(outfile1,*)
    write(outfile1,*) '--------------------'
    write(outfile1,*) 'NEW CALIBRATION TARGETS '
    write(outfile1,*) '--------------------'
    write(outfile1,*)
    write(outfile1,'(4a6,a7,a2,7a8)')  'beta', 'jstar','phi1','gam','minPsi','¦', &
                                      & 'A/Y', 'freqdef','arrears', 'spread','defsd', 'sprsd', &
                                      & 'debtsd' !09oct17

    write(outfile1,'(f6.3,i6,f6.3,f6.3,f7.3,a2,7f8.4)') &
                                    & beta, jzstar, phi1,gamma_psi, Psimin, &
                                    & '¦', &
                                    & AtoY, freqdef,  arrears, Spr, d_stdv, spr_stdv, &
                                    & debt_stdv !09oct17
!21jul18
       write(outfile1,*)
       write(outfile1,'(9a9,5a7,a7)') 'Rbar',  'phi1', 'gamma',  'Psimin', 'beta ',  &
            & 'AtoY', 'Spr', 'freqdef', 'arrears', &
            & 'defsd ', 'sprsd ', &
            & 'debtsd', &
            & 'r_yspr', 'sdC', &
            & 'smalld'
       write(outfile1,'(9f9.4,3f6.3,f7.3,f7.3,f7.3)')  Rbar_aver,  phi1, gamma_psi, Psimin, beta,   &
        & AtoY, Spr, freqdef, arrears, &
        & d_stdv, spr_stdv, &
        & debt_stdv, &
        & corrSpr, sdC, smalldef
END IF
 end subroutine report_stats

!**********************************************************
 subroutine simulpaths_stats
 implicit none
  CHARACTER(*), PARAMETER :: fileplace = "/data/home/tew158/partdef/v21/calibration/calib22mpi/simul/"
  open(297, file=fileplace//'simulpaths_stats.dat')
  write(297,'(a14,a14,a14)') 'y_aver'
  write(297,'(f14.6,f14.6,f14.6)') y_aver
  close(297)
 end subroutine simulpaths_stats

 subroutine simulpaths_yr_stats
 implicit none
  CHARACTER(*), PARAMETER :: fileplace = "/data/home/tew158/partdef/v21/calibration/calib22mpi/simul/"
  open(297, file=fileplace//'simulpaths_yr_stats.dat')
  write(297,'(a14)') 'y_aver'
  write(297,'(f14.6)') y_aver
  close(297)
 end subroutine simulpaths_yr_stats

!**********************************************************
!21jun17
 subroutine defaultevents
 implicit none

    integer :: time
!19jun17
    integer :: maxlengthdef, tdefevent, lengthtarget
    real(prec), allocatable :: y_defevent(:), z_defevent(:), &
        & a_defevent(:), b_defevent(:), &
        & spread_defevent(:), partdef_defevent(:)
    integer, allocatable  :: nsurvivedef(:)
    real(prec), allocatable :: c_defevent(:) !03mar19

    CHARACTER(*), PARAMETER :: fileplace = "/data/home/tew158/partdef/v21/calibration/calib22mpi/events/"
    character (len=2) :: lengthtarg_c

    logical, dimension(:), allocatable :: logicflag !06jan22
    real(prec) :: min_def

!   .. parametsr for Matlab filea ..
    open(297, file=fileplace//'defeventsparam.dat')
    write(297,'(a14,a14,a14,a14)') 'delta', 'q0', 'freq', 'zaver_glob'
    write(297,'(f14.6,f14.6,f14.6,f14.6)') delta, q0, modelfreq, zaver_glob
    close(297)

!  .. Find when def events begin and end ..

 deftime0=1
 deftime1=1

 defcount=0
 do time =1, ntime
    if(defcount.eq.0) then
     if( (partdef(time).gt.zero+small)) then
        defcount=defcount+1
        deftime0(defcount)=time
     end if
    else
     if( (partdef(time).gt.zero+small).and. &
       & (partdef(time-1).le.zero+small )) then
        defcount=defcount+1
        deftime0(defcount)=time
     end if
    end if
 end do

 defcount=0
 do time =1, ntime-1
     if( (partdef(time).gt.zero+small).and. &
       & (partdef(time+1).le.zero+small )) then
        defcount=defcount+1
        deftime1(defcount)=time
     end if
 end do

 ndefcount=defcount

! build variables for episodes: lenght, aver def, and spr

 allocate(lengthdef(ndefcount),averdef(ndefcount))
 allocate(averspr(ndefcount)) !14jun17
 allocate(averdebttoy(ndefcount),avery(ndefcount))  !22jun17
! allocate(initdebttoy(ndefcount), finaldebttoy(ndefcount), middebttoy(ndefcount)) !10jan19
! allocate(pre_initdebttoy(ndefcount), post_finaldebttoy(ndefcount)) !09feb21
allocate(  &
   &    initdebttoy(ndefcount), &
   &    finaldebttoy(ndefcount),&
   &    middebttoy(ndefcount), &
   &    pre_initdebttoy(ndefcount),  &
   &    post_finaldebttoy(ndefcount)    )
allocate(   &
   &   pre_initdef     (ndefcount), &
   &   initdef         (ndefcount), &
   &   middef          (ndefcount), &
   &   finaldef        (ndefcount), &
   &   post_finaldef   (ndefcount), &
   &   pre_initspr     (ndefcount), &
   &   initspr         (ndefcount), &
   &   midspr          (ndefcount), &
   &   finalspr        (ndefcount), &
   &   post_finalspr   (ndefcount), &
   &   pre_inity       (ndefcount), &
   &   inity           (ndefcount), &
   &   midy            (ndefcount), &
   &   finaly          (ndefcount), &
   &   post_finaly     (ndefcount), &
   &   pre_initc       (ndefcount), &
   &   initc           (ndefcount), &
   &   midc            (ndefcount), &
   &   finalc          (ndefcount), &
   &   post_finalc     (ndefcount)     )

 do defcount=1, ndefcount
 lengthdef(defcount)= deftime1(defcount)-deftime0(defcount)+1
 averdef(defcount)=sum(partdef(deftime0(defcount):deftime1(defcount))) &
        & /real(lengthdef(defcount))
 averspr(defcount)=sum(spread(deftime0(defcount):deftime1(defcount))) &
        & /real(lengthdef(defcount)) !14jun17
 averdebttoy(defcount)=sum( &
        & a(deftime0(defcount):deftime1(defcount))/y(deftime0(defcount):deftime1(defcount)) &
        & ) &
        & /real(lengthdef(defcount)) !22jun17

!10jan19
!09feb21
! initdebttoy(defcount)= &
!    & a(deftime0(defcount))/y(deftime0(defcount))
! finaldebttoy(defcount)= &
!    & a(deftime1(defcount))/y(deftime1(defcount))
! middebttoy(defcount)= &
!    & a( int((deftime0(defcount)+deftime1(defcount))/two) )  &
!    & / y( int((deftime0(defcount)+deftime1(defcount))/two)  )
!!    & a( int((.25_prec*deftime0(defcount)+.75_prec*deftime1(defcount))) )  &
!!    & / y( int((.25_prec*deftime0(defcount)+.75_prec*deftime1(defcount)))  )
!
! pre_initdebttoy(defcount)= &
!    & a(max(1,deftime0(defcount)-1))/y(max(1,deftime0(defcount)-1))
! post_finaldebttoy(defcount)= &
!    & a(min(deftime1(defcount)+1,ntime))/y(min(deftime1(defcount)+1,ntime))
 pre_initdebttoy(defcount)= &
    & a(max(1,deftime0(defcount)-1))/y(max(1,deftime0(defcount)-1))
 initdebttoy(defcount)= &
    & a(deftime0(defcount))/y(deftime0(defcount))
 middebttoy(defcount)= &
    & a( int((deftime0(defcount)+deftime1(defcount))/two) )  &
    & / y( int((deftime0(defcount)+deftime1(defcount))/two)  )
 finaldebttoy(defcount)= &
    & a(deftime1(defcount))/y(deftime1(defcount))
 post_finaldebttoy(defcount)= &
    & a(min(deftime1(defcount)+1,ntime))/y(min(deftime1(defcount)+1,ntime))

 pre_initdef(defcount)= &
    & partdef(max(1,deftime0(defcount)-1))
 initdef(defcount)= &
    & partdef(deftime0(defcount))
 middef(defcount)= &
    & partdef( int((deftime0(defcount)+deftime1(defcount))/two) )
 finaldef(defcount)= &
    & partdef(deftime1(defcount))
 post_finaldef(defcount)= &
    & partdef(min(deftime1(defcount)+1,ntime))

 pre_initspr(defcount)= &
    & spread(max(1,deftime0(defcount)-1))
 initspr(defcount)= &
    & spread(deftime0(defcount))
 finalspr(defcount)= &
    & spread(deftime1(defcount))
 midspr(defcount)= &
    & spread( int((deftime0(defcount)+deftime1(defcount))/two) )
 post_finalspr(defcount)= &
    & spread(min(deftime1(defcount)+1,ntime))

 pre_inity(defcount)= &
    & log(y(max(1,deftime0(defcount)-1)))-log(y_aver)
 inity(defcount)= &
    & log(y(deftime0(defcount)))-log(y_aver)
 finaly(defcount)= &
    & log(y(deftime1(defcount)))-log(y_aver)
 midy(defcount)= &
    & log(y(int((deftime0(defcount)+deftime1(defcount))/two) ))-log(y_aver)
 post_finaly(defcount)= &
    & log(y(min(deftime1(defcount)+1,ntime)))-log(y_aver)

 pre_initc(defcount)= &
    & log(c(max(1,deftime0(defcount)-1)))-log(cons_aver)
 initc(defcount)= &
    & log(c(deftime0(defcount)))-log(cons_aver)
 finalc(defcount)= &
    & log(c(deftime1(defcount)))-log(cons_aver)
 midc(defcount)= &
    & log(c(int((deftime0(defcount)+deftime1(defcount))/two) ))-log(cons_aver)
 post_finalc(defcount)= &
    & log(c(min(deftime1(defcount)+1,ntime)))-log(cons_aver)

 avery(defcount)=sum( &
        & log(y(deftime0(defcount):deftime1(defcount))) &
        & ) &
        & /real(lengthdef(defcount)) !22jun17
 end do

! .. construct analysis of default events ..

if(doEVENT.eq.1) then !19jun17

!19jun17
   maxlengthdef=maxval(lengthdef(1:ndefcount))
   allocate(nsurvivedef(0:maxlengthdef), &
        & y_defevent(0:maxlengthdef), &
        & z_defevent(0:maxlengthdef), &
        & a_defevent(0:maxlengthdef), &
        & b_defevent(0:maxlengthdef), &
        & spread_defevent(0:maxlengthdef), &
        & partdef_defevent(0:maxlengthdef) &
        & )
!19jun17
    !first event is defcount=2 to ensure there is a previous no-def period
    ! Event period zero, where def is zero
    nsurvivedef(0)=ndefcount-1
    y_defevent(0)=sum(y(deftime0(2:ndefcount)-1))
    y_defevent(0)=y_defevent(0)/real(ndefcount-1)
    z_defevent(0)=sum(z(deftime0(2:ndefcount)-1))
    z_defevent(0)=z_defevent(0)/real(ndefcount-1)
    a_defevent(0)=sum(a(deftime0(2:ndefcount)-1))
    a_defevent(0)=a_defevent(0)/real(ndefcount-1)
    b_defevent(0)=sum(b(deftime0(2:ndefcount)-1))
    b_defevent(0)=b_defevent(0)/real(ndefcount-1)
    spread_defevent(0)=sum(spread(deftime0(2:ndefcount)-1))
    spread_defevent(0)=spread_defevent(0)/real(ndefcount-1)
    partdef_defevent(0)=sum(partdef(deftime0(2:ndefcount)-1))
    partdef_defevent(0)=partdef_defevent(0)/real(ndefcount-1)
!!19jun17
    do tdefevent=1, maxlengthdef
     nsurvivedef(tdefevent)=count(lengthdef(2:ndefcount).ge.tdefevent)
     y_defevent(tdefevent)= &
        & sum(y(deftime0(2:ndefcount)+tdefevent-1),  &
        &   lengthdef(2:ndefcount).ge.tdefevent)
     y_defevent(tdefevent)=y_defevent(tdefevent)/real(nsurvivedef(tdefevent))
     z_defevent(tdefevent)= &
        & sum(z(deftime0(2:ndefcount)+tdefevent-1),  &
        &   lengthdef(2:ndefcount).ge.tdefevent)
     z_defevent(tdefevent)=z_defevent(tdefevent)/real(nsurvivedef(tdefevent))
     a_defevent(tdefevent)= &
        & sum(a(deftime0(2:ndefcount)+tdefevent-1),  &
        &   lengthdef(2:ndefcount).ge.tdefevent)
     a_defevent(tdefevent)=a_defevent(tdefevent)/real(nsurvivedef(tdefevent))
     b_defevent(tdefevent)= &
        & sum(b(deftime0(2:ndefcount)+tdefevent-1),  &
        &   lengthdef(2:ndefcount).ge.tdefevent)
     b_defevent(tdefevent)=b_defevent(tdefevent)/real(nsurvivedef(tdefevent))
     spread_defevent(tdefevent)= &
        & sum(spread(deftime0(2:ndefcount)+tdefevent-1),  &
        &   lengthdef(2:ndefcount).ge.tdefevent)
     spread_defevent(tdefevent)=spread_defevent(tdefevent)/real(nsurvivedef(tdefevent))
     partdef_defevent(tdefevent)= &
        & sum(partdef(deftime0(2:ndefcount)+tdefevent-1),  &
        &   lengthdef(2:ndefcount).ge.tdefevent)
     partdef_defevent(tdefevent)=partdef_defevent(tdefevent)/real(nsurvivedef(tdefevent))
    end do

    open(42, file='defevents.dat')
    write(42,*) ' --------------------'
    write(42,*) ' PATHS '
    write(42,*) ' --------------------'
    write(42,*) 'time, y,  z, a, b, partdef, spr, probexit '
        do tdefevent=0, maxlengthdef
        write(42,'( &
                    & i6,f10.6,f10.6,f10.6, &
                    & f10.6,f10.6, &
                    & f10.6, &
                    & f10.6)') &
            & tdefevent, y_defevent(tdefevent),  z_defevent(tdefevent), a_defevent(tdefevent),  &
            & b_defevent(tdefevent), partdef_defevent(tdefevent), &
            & spread_defevent(tdefevent),  &
            & one-real(nsurvivedef(tdefevent))/real(ndefcount-1)
        end do
    close(42)

!19jun17
    deallocate(nsurvivedef,y_defevent,z_defevent, &
        & a_defevent,b_defevent,spread_defevent,partdef_defevent)


else if(doEVENT.eq.2) then
    ! Events of an exact duration lengthdef(defcount).eq.lengthtarget
    !first possible event is defcount=2 to ensure there is a previous no-def period
    ! Event period zero, where def is zero

    ! set length
    lengthtarget=lengthevent !3

   allocate(nsurvivedef(0:maxlengthdef), &
        & y_defevent(0:lengthtarget), &
        & z_defevent(0:lengthtarget), &
        & a_defevent(0:lengthtarget), &
        & b_defevent(0:lengthtarget), &
        & spread_defevent(0:lengthtarget), &
        & partdef_defevent(0:lengthtarget) &
        & )
   allocate( c_defevent(0:lengthtarget)) !03mar19

    nsurvivedef(0)=count(lengthdef(2:ndefcount).eq.lengthtarget)
    y_defevent(0)=sum(y(deftime0(2:ndefcount)-1), &
            & (lengthdef(2:ndefcount).eq.lengthtarget))
    y_defevent(0)=y_defevent(0)/real(nsurvivedef(0))
    z_defevent(0)=sum(z(deftime0(2:ndefcount)-1), &
            & (lengthdef(2:ndefcount).eq.lengthtarget))
    z_defevent(0)=z_defevent(0)/real(nsurvivedef(0))
    a_defevent(0)=sum(a(deftime0(2:ndefcount)-1), &
            & (lengthdef(2:ndefcount).eq.lengthtarget))
    a_defevent(0)=a_defevent(0)/real(nsurvivedef(0))
    b_defevent(0)=sum(b(deftime0(2:ndefcount)-1), &
            & (lengthdef(2:ndefcount).eq.lengthtarget))
    b_defevent(0)=b_defevent(0)/real(nsurvivedef(0))
    spread_defevent(0)=sum(spread(deftime0(2:ndefcount)-1), &
            & (lengthdef(2:ndefcount).eq.lengthtarget))
    spread_defevent(0)=spread_defevent(0)/real(nsurvivedef(0))
    partdef_defevent(0)=sum(partdef(deftime0(2:ndefcount)-1), &
            & (lengthdef(2:ndefcount).eq.lengthtarget))
    partdef_defevent(0)=partdef_defevent(0)/real(nsurvivedef(0))

    !03mar19
    c_defevent(0)=sum(c(deftime0(2:ndefcount)-1), &
            & (lengthdef(2:ndefcount).eq.lengthtarget))
    c_defevent(0)=c_defevent(0)/real(nsurvivedef(0))

!24jul18     do tdefevent=1, lengthtarget
    do tdefevent=1, lengthtarget+1 !24jul18
     y_defevent(tdefevent)= &
        & sum(y(deftime0(2:ndefcount)+tdefevent-1),  &
        &   lengthdef(2:ndefcount).eq.lengthtarget)
     y_defevent(tdefevent)=y_defevent(tdefevent)/real(nsurvivedef(0))
     z_defevent(tdefevent)= &
        & sum(z(deftime0(2:ndefcount)+tdefevent-1),  &
        &   lengthdef(2:ndefcount).eq.lengthtarget)
     z_defevent(tdefevent)=z_defevent(tdefevent)/real(nsurvivedef(0))
     a_defevent(tdefevent)= &
        & sum(a(deftime0(2:ndefcount)+tdefevent-1),  &
        &   lengthdef(2:ndefcount).eq.lengthtarget)
     a_defevent(tdefevent)=a_defevent(tdefevent)/real(nsurvivedef(0))
     b_defevent(tdefevent)= &
        & sum(b(deftime0(2:ndefcount)+tdefevent-1),  &
        &   lengthdef(2:ndefcount).eq.lengthtarget)
     b_defevent(tdefevent)=b_defevent(tdefevent)/real(nsurvivedef(0))
     spread_defevent(tdefevent)= &
        & sum(spread(deftime0(2:ndefcount)+tdefevent-1),  &
        &   lengthdef(2:ndefcount).eq.lengthtarget)
     spread_defevent(tdefevent)=spread_defevent(tdefevent)/real(nsurvivedef(0))
     partdef_defevent(tdefevent)= &
        & sum(partdef(deftime0(2:ndefcount)+tdefevent-1),  &
        &   lengthdef(2:ndefcount).eq.lengthtarget)
     partdef_defevent(tdefevent)=partdef_defevent(tdefevent)/real(nsurvivedef(0))

    !03mar19
     c_defevent(tdefevent)= &
        & sum(c(deftime0(2:ndefcount)+tdefevent-1),  &
        &   lengthdef(2:ndefcount).eq.lengthtarget)
     c_defevent(tdefevent)=c_defevent(tdefevent)/real(nsurvivedef(0))
    end do

    if(lengthtarget.ge.10) write(lengthtarg_c,'(i2)') lengthtarget
    if(lengthtarget.lt.10) write(lengthtarg_c,'(i1)') lengthtarget
    open(42, file=fileplace//'defevents_lenyr'//trim(lengthtarg_c)//'.dat')
    !open(42, file=fileplace//'defevents_lenyr.dat')
    write(42,*) ' --------------------'
    write(42,*) ' PATHS '
    write(42,*) ' --------------------'
    write(42,*) 'time, y,  z, a, b, partdef, spr, cons  '
!24jul18        do tdefevent=0, lengthtarget
        do tdefevent=0, maxlengthevent+1
        !do tdefevent=0, lengthtarget+1 !24jul18
!        write(42,'( &
!                    & i6,f10.6,f10.6,f10.6, &
!                    & f10.6,f10.6, &
!                    & f10.6, f10.6 &
!                    & )') &
!            & tdefevent, y_defevent(tdefevent),  z_defevent(tdefevent), a_defevent(tdefevent),  &
!            & b_defevent(tdefevent), partdef_defevent(tdefevent), &
!            & spread_defevent(tdefevent), c_defevent(tdefevent) !03mar19
        if(tdefevent.le.lengthtarget+1) then
        write(42,'( &
                    & i6,f10.6,f10.6,f10.6, &
                    & f10.6,f10.6, &
                    & f10.6, f10.6 &
                    & )') &
            & tdefevent, y_defevent(tdefevent),  z_defevent(tdefevent), a_defevent(tdefevent),  &
            & b_defevent(tdefevent), partdef_defevent(tdefevent), &
            & spread_defevent(tdefevent), c_defevent(tdefevent) !03mar19
        else
        write(42,'( i6,7a10)') &
            & tdefevent, 'NaN', 'NaN', 'NaN', 'NaN', 'NaN', 'NaN', 'NaN'
        end if

        end do
    close(42)

    deallocate(nsurvivedef,y_defevent,z_defevent, &
        & a_defevent,b_defevent,spread_defevent,partdef_defevent, &
        & c_defevent) !03mar19


else if (doEVENT.eq.3) then
! Histogram of length of default

  maxlengthdef=maxval(lengthdef(1:ndefcount))
  allocate(nsurvivedef(0:maxlengthdef))
  do lengthtarget=1, maxlengthdef
    nsurvivedef(lengthtarget)=count(lengthdef(1:ndefcount).eq.lengthtarget)
  end do

    open(42, file='histoglength.dat')
    write(42,*) ' --------------------'
    write(42,*) ' HISTOGRAM '
    write(42,*) ' --------------------'
    write(42,*) 'time, y,  z, a, b, partdef, spr, probexit '
        do lengthtarget=1, maxlengthdef
        write(42,'( &
                    & i6,f10.6 &
                    &           )') &
            & lengthtarget, real(nsurvivedef(lengthtarget))/real(ndefcount)
        end do
    close(42)
    deallocate(nsurvivedef)

end if


!06jan22
if (doEVENT.eq.4) then

    min_def=0.40_prec
    maxlengthdef=10 !maxval(lengthdef(1:ndefcount))

   allocate(nsurvivedef(0:maxlengthdef), &
        & y_defevent(0:maxlengthdef), &
        & z_defevent(0:maxlengthdef), &
        & a_defevent(0:maxlengthdef), &
        & b_defevent(0:maxlengthdef), &
        & spread_defevent(0:maxlengthdef), &
        & partdef_defevent(0:maxlengthdef) &
        & )
   allocate( c_defevent(0:maxlengthdef))
   allocate(logicflag(ndefcount))

    !
    ! Events
    !
    do tdefevent=0, maxlengthdef
      where ((lengthdef(2:ndefcount).ge.tdefevent) &
        &   .and.   &
        &  (initdef(2:ndefcount).ge.min_def)       )
        logicflag(2:ndefcount)=.true.
      elsewhere
        logicflag(2:ndefcount)=.false.
      end where

     nsurvivedef(tdefevent)=count(logicflag(2:ndefcount))
     y_defevent(tdefevent)= &
        & sum(y(deftime0(2:ndefcount)+tdefevent-1),logicflag(2:ndefcount))
     y_defevent(tdefevent)=y_defevent(tdefevent)/real(nsurvivedef(tdefevent))
     z_defevent(tdefevent)= &
        & sum(z(deftime0(2:ndefcount)+tdefevent-1),logicflag(2:ndefcount))
     z_defevent(tdefevent)=z_defevent(tdefevent)/real(nsurvivedef(tdefevent))
     a_defevent(tdefevent)= &
        & sum(a(deftime0(2:ndefcount)+tdefevent-1),logicflag(2:ndefcount))
     a_defevent(tdefevent)=a_defevent(tdefevent)/real(nsurvivedef(tdefevent))
     b_defevent(tdefevent)= &
        & sum(b(deftime0(2:ndefcount)+tdefevent-1),logicflag(2:ndefcount))
     b_defevent(tdefevent)=b_defevent(tdefevent)/real(nsurvivedef(tdefevent))
     spread_defevent(tdefevent)= &
        & sum(spread(deftime0(2:ndefcount)+tdefevent-1),logicflag(2:ndefcount))
     spread_defevent(tdefevent)=spread_defevent(tdefevent)/real(nsurvivedef(tdefevent))
     partdef_defevent(tdefevent)= &
        & sum(partdef(deftime0(2:ndefcount)+tdefevent-1),logicflag(2:ndefcount))
     partdef_defevent(tdefevent)=partdef_defevent(tdefevent)/real(nsurvivedef(tdefevent))
     c_defevent(tdefevent)= &
        & sum(c(deftime0(2:ndefcount)+tdefevent-1),logicflag(2:ndefcount))
     c_defevent(tdefevent)=c_defevent(tdefevent)/real(nsurvivedef(tdefevent))
    end do


    open(42, file='defevents_def40pc.dat')
    write(42,*) ' --------------------'
    write(42,*) ' PATHS '
    write(42,*) ' --------------------'
    write(42,*) 'time, y,  z, a, b, partdef, spr, survive '
        do tdefevent=0, maxlengthdef
        write(42,'( &
                    & i6,f10.6,f10.6,f10.6, &
                    & f10.6,f10.6, &
                    & f10.6, &
                    & i10)') &
            & tdefevent, y_defevent(tdefevent),  z_defevent(tdefevent), a_defevent(tdefevent),  &
            & b_defevent(tdefevent), partdef_defevent(tdefevent), &
            & spread_defevent(tdefevent),  &
            & nsurvivedef(tdefevent)
        end do
    close(42)

    deallocate(nsurvivedef,y_defevent,z_defevent, &
        & a_defevent,b_defevent,spread_defevent,partdef_defevent)
    deallocate(logicflag)

end if


 end subroutine defaultevents

! ----------------------------------------------------------------------
!20jul18
 subroutine haircuts_extensions(r_yr, del_yr)
 implicit none

 real(prec) r_yr, del_yr, aL, aNEW
 integer :: time
 real(prec) :: valOLD_aver,durOLD_aver,valNEW_aver,durNEW_aver

 real(prec), dimension(:), allocatable :: valOLD(:), durOLD(:), &
        &                   valNEW(:), durNEW(:), &
        &                   hairc(:), extens(:)
    !These variables will later go global in [defaultevents]

 integer :: lengthtarget, maxlengthdef
 real(prec) ::  haircut_bylength, extens_bylength, valOLD_bylength, durOLD_bylength
 integer ::     nevents_bylength


    allocate(valOLD(ndefcount),durOLD(ndefcount), &
        & valNEW(ndefcount),durNEW(ndefcount))

 allocate(averhairc(ndefcount-1)) !25jul18

 valOLD=zero
 durOLD=zero
 valNEW=zero
 durNEW=zero

 averhairc=zero !25jul18

 ! delta_yr=delta**4, r_yr=1-(1+r)^4 with 1+r=1/q0


 do defcount=1, ndefcount-1
 ! .. Compute duration of event defcount ..
 ! Need:
 ! partdef(deftime0(defcount):deftime1(defcount))
 ! b(deftime0(defcount):deftime1(defcount))
 ! RRbar(deftime0(defcount):deftime1(defcount))
 ! a(deftime0(defcount):deftime1(defcount))
 ! a(deftime1(defcount)+1)
 ! length(defcount)




    !
    ! .. Defaulted debts ..
    !
    do time=deftime0(defcount),deftime1(defcount)
    valOLD(defcount)= valOLD(defcount) &
            &   +(partdef(time)*a(time)) &
            &       / ((one+r_yr)**(real(time-deftime0(defcount)+1-1)))
    durOLD(defcount)=durOLD(defcount) &
            &   +   (real(time-deftime0(defcount)+1)) &
            &     * (partdef(time)*a(time)) &
            &       / ((one+r_yr)**(real(time-deftime0(defcount)+1-1)))
    end do
    durOLD(defcount)=durOLD(defcount)/valOLD(defcount)

    !
    ! .. Arrears paid ..
    !
!    aL=a(deftime0(defcount))
    aNEW=zero
    if(deftime1(defcount).ge.deftime0(defcount)+1) then
     do time=deftime0(defcount)+1,deftime1(defcount)
! v1: in terms of diff at at-1
!      aL=del_yr*a(time-1)+b(time-1) !my version
!      !!!aL=del_yr*aL+b(time-1) !version Cristina
!      valAP(defcount)= valAP(defcount) &
!        &   + ( (one-partdef(time))*(a(time)-aL)) &
!        &   / ((one+r_yr)**(real(time-deftime0(defcount)+1-1)))
! v1: in terms of (1-del)R d a
!      valAP(defcount)= valAP(defcount) &
!        &   + ( (one-partdef(time))*(one-del_yr)*RRbar(time-1)*partdef(time-1)*a(time-1)) &
!        &   / ((one+r_yr)**(real(time-deftime0(defcount)+1-1)))
! v2:
      aNEW=(one-del_yr)*RRbar(time-1)*partdef(time-1)*a(time-1)+del_yr*aNEW
      valNEW(defcount)= valNEW(defcount) &
        &   + ((one-partdef(time))* aNEW )&
        &   / ((one+r_yr)**(real(time-deftime0(defcount)+1-1)))
!        &   + ( -partdef(time)*(one-del_yr)*RRbar(time-1)*partdef(time-1)*a(time-1)+defL )&
!        &   / ((one+r_yr)**(real(time-deftime0(defcount)+1-1)))

      durNEW(defcount)= durNEW(defcount) &
        &   + real(time-deftime0(defcount)+1) &
        &   * ((one-partdef(time))* aNEW )&
        &   / ((one+r_yr)**(real(time-deftime0(defcount)+1-1)))
!
!        &   + real(time-deftime0(defcount)+1)   &
!        &   * ( (one-partdef(time))*(a(time)-aL)) &
!        &   / ((one+r_yr)**(real(time-deftime0(defcount)+1-1)))
     end do
    end if
! v1: in terms of diff at at-1
!     aL=del_yr*a(deftime1(defcount))+b(deftime1(defcount)) !my version
!      !!!aL=del_yr*aL+b(deftime1(defcount)) !Cristina'a
!       valAP(defcount)= valAP(defcount) &
!        & + ((one+r_yr)/(one+r_yr-del_yr)) &
!        & * (  ( (a(min(deftime1(defcount)+1,ntime))-aL)) &
!        & / ((one+r_yr)**(real(deftime1(defcount)-deftime0(defcount)+1))) )
! v1: in terms of (1-del)R d a
!       valAP(defcount)= valAP(defcount) &
!        & + ((one+r_yr)/(one+r_yr-del_yr)) &
!        & * (  ( ((one-del_yr)*RRbar(deftime1(defcount)+1)*partdef(deftime1(defcount))*a(deftime1(defcount)))) &
!        & / ((one+r_yr)**(real(deftime1(defcount)-deftime0(defcount)+1))) )
! v2:
      aNEW=(one-del_yr)*RRbar(deftime1(defcount))*partdef(deftime1(defcount))*a(deftime1(defcount)) &
            &   + del_yr*aNEW
       valNEW(defcount)= valNEW(defcount) &
        & + ((one+r_yr)/(one+r_yr-del_yr)) &
        &   * ( (aNEW )&
        & / ((one+r_yr)**(real(deftime1(defcount)-deftime0(defcount)+1))) )

      durNEW(defcount)= durNEW(defcount) &
        &   + ( (aNEW )&
        &  / ((one+r_yr)**(real(deftime1(defcount)-deftime0(defcount)+1))) ) &
        &   *(       &
        &       (real(deftime1(defcount)-deftime0(defcount)+1)) &
        &           * ((one+r_yr)/(one+r_yr-del_yr)) &
!11jan19        &       +(one/(one-(del_yr/(one+r_yr))**(two))) &
        &       +(one/((one-(del_yr/(one+r_yr)))**(two))) &
        &       )
!        &   + (  ( (a(min(deftime1(defcount)+1,ntime))-aL)) &
!        & / ((one+r_yr)**(real(deftime1(defcount)-deftime0(defcount)+1))) ) &
!        &   *(       &
!        &       (real(deftime1(defcount)-deftime0(defcount)+1)) &
!        &           * ((one+r_yr)/(one+r_yr-del_yr)) &
!        &       +(one/(one-(del_yr/(one+r_yr))**(two))) &
!        &       )
      durNEW(defcount)= durNEW(defcount)/valNEW(defcount)

      averhairc(defcount)=one-valNEW(defcount)/valOLD(defcount) !25jul18

!!!    write(outfile1,*) valNEW(defcount)/valOLD(defcount),  RRbar(deftime1(defcount)), partdef(deftime1(defcount))

 end do



    valOLD_aver=sum(valOLD(1:ndefcount-1))/real(ndefcount-1)
    durOLD_aver=sum(durOLD(1:ndefcount-1))/real(ndefcount-1)
    valNEW_aver=sum(valNEW(1:ndefcount-1))/real(ndefcount-1)
    durNEW_aver=sum(durNEW(1:ndefcount-1))/real(ndefcount-1)

    write(outfile1,*)
!15sep18
 write(outfile1,*)
 write(outfile1,*)
 write(outfile1,*) 'delta = ', delta, 'r  = ',  (one/q0)-one
 write(outfile1,*) 'riskfree duration quarterly freq', &
    &   (one/q0)/((one/q0)-delta)
 write(outfile1,*) 'delta adj= ', del_yr, 'r adj = ',  r_yr
 write(outfile1,*) 'riskfree duration adjusted freq (x4 if annual)', &
    &   (one+r_yr)/(one+r_yr-del_yr)
    write(outfile1,*) 'delta= ', del_yr, 'r = ',  r_yr
    write(outfile1,*) 'HAIRCUTS AND MATURITY EXTENSIONS '
    write(outfile1,*) 'aver valOLD', valOLD_aver
    write(outfile1,*) 'aver durOLD', durOLD_aver
    write(outfile1,*) 'aver valNEW', valNEW_aver
    write(outfile1,*) 'aver durNEW', durNEW_aver
! haircut_bylength=zero
! do defcount=1, ndefcount-1
!    haircut_bylength=haircut_bylength+one-valNEW(defcount)/valOLD(defcount)
! end do

    haircut_stat= one - sum((valNEW(1:ndefcount-1)/valOLD(1:ndefcount-1)))/real(ndefcount-1) !10feb21
    write(outfile1,*) 'haircut', haircut_stat !10feb21
       !10feb21 &           one - sum((valNEW(1:ndefcount-1)/valOLD(1:ndefcount-1)))/real(ndefcount-1)
    write(outfile1,*) 'haircut (2)', sum(averhairc(1:ndefcount-1))/real(ndefcount-1) !25jul18

    write(outfile1,*) 'max/min haircut', one-minval(valNEW(1:ndefcount-1)/valOLD(1:ndefcount-1)), one-maxval(valNEW(1:ndefcount-1)/valOLD(1:ndefcount-1))
    extension_stat=sum(durNEW(1:ndefcount-1)-durOLD(1:ndefcount-1))/real(ndefcount-1) !10feb21
    write(outfile1,*) 'extension', extension_stat !10feb21
        !10feb21 &           sum(durNEW(1:ndefcount-1)-durOLD(1:ndefcount-1))/real(ndefcount-1)





 write(outfile1,*) 'HAIRCUTS AND EXTENSIONS BY LENGTH '
 write(outfile1,'(a7,a9,a9,a9,a9)') &
            &       'length', 'valOLD', 'durOLD', &
            &       'haircut', 'extens'


 maxlengthdef=maxval(lengthdef(1:ndefcount-1))

 do lengthtarget=1, min(10,maxlengthdef)

 haircut_bylength=zero
 extens_bylength=zero
 valOLD_bylength=zero
 durOLD_bylength=zero
 nevents_bylength=count(lengthdef(1:ndefcount-1).eq.lengthtarget)
 do defcount=1, ndefcount-1
 if(lengthdef(defcount).eq.lengthtarget) then
    haircut_bylength=haircut_bylength+ &
        & (one-valNEW(defcount)/valOLD(defcount))
    extens_bylength=extens_bylength+ &
        &   durNEW(defcount)-durOLD(defcount)
    valOLD_bylength=valOLD_bylength+ &
        &   valOLD(defcount)
    durOLD_bylength=durOLD_bylength+ &
        &   durOLD(defcount)
 end if
 end do
 haircut_bylength=haircut_bylength/real(nevents_bylength)
 extens_bylength =extens_bylength/real(nevents_bylength)
 valOLD_bylength=valOLD_bylength/real(nevents_bylength)
 durOLD_bylength=durOLD_bylength/real(nevents_bylength)

 write(outfile1,'(i7,f9.5,f9.5,f9.5,f9.5)') &
            &       lengthtarget, valOLD_bylength, durOLD_bylength, &
            &       haircut_bylength, extens_bylength

 end do



 end subroutine haircuts_extensions

! ---------------------------------------------------------------------
!23jul18
 subroutine haircbyvintage(r_yr, del_yr)

    implicit none

    real(prec) r_yr, del_yr
    real(prec), dimension(:), allocatable :: vNEW(:), vOLD(:), hairc(:)
    real(prec) ::  aNEW, aL, vOLDtemp, vNEWtemp
    integer :: nlength, lengthtarget, tt0
    integer :: jj

    !del_yr=delta**4.0_prec
    !r_yr=((one/q0)**4.0_prec)-one

    lengthtarget=10
    if(lengthtarget.lt.2) then
        write(*,*) ' lengthtarget must be at least 2!! '
        stop
    end if
    nlength=count(lengthdef(2:ndefcount-1).eq.lengthtarget)


    allocate(vNEW(lengthtarget), vOLD(lengthtarget), hairc(lengthtarget))

vNEW=zero
vOLD=zero
hairc=zero
do defcount=2, ndefcount-1

 if (lengthdef(defcount).eq.lengthtarget) then

    ! For a particular event defcount
    ! calculate haircuts

  ! .. over age of legacy debts jj=1, ..., N ..

  do jj=1,  lengthtarget

    ! .. over periods of the episode  ..
        aNEW=zero
        aL=zero
        vOLDtemp=zero
        vNEWtemp=zero
        ! --------------------------
        !
        do time=deftime0(defcount)+1,deftime1(defcount)
          aNEW=(one-del_yr)*RRbar(time-1)*partdef(time-1)*aL+del_yr*aNEW
          tt0=deftime0(defcount)+jj-1
          if(time.lt.tt0) then
           aL=zero
          else if ((jj.eq.1)) then
           aL=(del_yr**(real(time-tt0)))*a(deftime0(defcount))
          else
           aL=(del_yr**(real(time-tt0)))*b(tt0-1)
          end if
          vOLDtemp = vOLDtemp &
            &   +(partdef(time)*aL) &
            &       / ((one+r_yr)**(real(time-deftime0(defcount))))
          vNEWtemp=vNEWtemp &
        &   + ((one-partdef(time))* aNEW  )&
        &   / ((one+r_yr)**(real(time-deftime0(defcount))))
        end do ! .. time loop ..
          time=deftime1(defcount)+1
          aNEW=(one-del_yr)*RRbar(time-1)*partdef(time-1)*aL+del_yr*aNEW
          vNEWtemp=vNEWtemp &
            & + ((one+r_yr)/(one+r_yr-del_yr)) &
            &   * ( (aNEW )&
            & / ((one+r_yr)**(real(time-deftime0(defcount)))) )

!          tt=time-deftime0(defcount)+1
!          if (tt.lt.jj) then
!           aL=zero
!          else if ((jj.eq.1)) then
!           aL=(del_yr**(real(tt-jj)))*a(deftime0(defcount)+jj-1)
!          else
!            aL=(del_yr**(real(tt-jj)))*b(deftime0(defcount)+jj-1)
!          end if
!          wL=aL/(a(time)-aNEW)
!          vOLDtemp = vOLDtemp &
!            &   +(partdef(time)*aL) &
!            &       / ((one+r_yr)**(real(tt-1)))
!          vNEWtemp=vNEWtemp &
!        &   + ((one-partdef(time))* aNEW * wL )&
!        &   / ((one+r_yr)**(real(tt-1)))
!        end do ! .. time loop ..
!        time=deftime1(defcount)+1
!        aNEW=(one-del_yr)*RRbar(time-1)*partdef(time-1)*a(time-1)+del_yr*aNEW
!        tt=time-deftime0(defcount)+1
!          if (tt.lt.jj) then
!           aL=zero
!          else if ((jj.eq.1)) then
!           aL=(del_yr**(real(tt-jj)))*a(deftime0(defcount)+jj-1)
!          else
!            aL=(del_yr**(real(tt-jj)))*b(deftime0(defcount)+jj-1)
!          end if
!          wL=aL/(a(time)-aNEW)
!          vNEWtemp=vNEWtemp &
!            & + ((one+r_yr)/(one+r_yr-del_yr)) &
!            &   * ( (aNEW *wL )&
!            & / ((one+r_yr)**(real(tt))) )
        !
        ! --------------------------
        vOLD(jj)=vOLD(jj)+vOLDtemp
        vNEW(jj)=vNEW(jj)+vNEWtemp
        hairc(jj)=hairc(jj)+one-vNEWtemp/vOLDtemp

  end do ! .. jj loop ..

 end if

end do ! .. defcount loop ..

    vOLD=vOLD/real(nlength)
    vNEW=vNEW/real(nlength)
    hairc=hairc/real(nlength)


 write(outfile1,*)
 write(outfile1,*) 'HAIRCUTS BY PERIOD FIRST DUE (vintage) '
 write(outfile1,*) 'EPISODES OF LENGTH ',  lengthtarget
 write(outfile1,'(a7,a9,a9,a9)') &
            &       'vintage', 'vOLD', 'vNEW', &
            &       'haircut'

 do jj=1,  lengthtarget
 write(outfile1,'(i7,f9.5,f9.5,f9.5)') &
            &       jj, vOLD(jj), vnew(jj), &
            &       hairc(jj)
 end do


 deallocate(vNEW, vOLD, hairc)

 end subroutine haircbyvintage

!-----------------------------------------------------------------------
!11feb17
subroutine slope_coeffs
use Percentile_mod !12may18
implicit none

 real(prec), dimension(:), allocatable :: rlengthdef(:) !12may18

 integer :: time
!21jun17 integer :: deftime0(ntime),deftime1(ntime)
!21jun17 integer :: defcount, ndefcount
!21jun17 real(prec), dimension(:), allocatable :: averdef(:), averspr(:)
!21jun17 integer, dimension(:), allocatable :: lengthdef(:)
 real(prec), dimension(:), allocatable :: x_mat(:,:), y_mat(:)
 real(prec) :: beta(2)
 real(prec) :: length_aver, def_aver, length_sd, def_sd, corr_dlength !14feb17
 real(prec) :: length_median     !12may18
 real(prec) :: spr_aver, spr_sd, corr_sprlength
 real(prec) :: debttoy_aver, debttoy_sd, corr_debttoylength !22jun17
 real(prec) :: y_aver, y_sd, corr_ylength
 real(prec) :: hairc_aver, hairc_sd, corr_hairclength   !25jul18

 real(prec) ::   initdebttoy_aver,          &
              &  finaldebttoy_aver,         &
              &  middebttoy_aver,           &
              &  pre_initdebttoy_aver,      &
              &  post_finaldebttoy_aver
 real(prec) ::  &
   &   pre_initdef_aver    , &
   &   initdef_aver        , &
   &   middef_aver         , &
   &   finaldef_aver       , &
   &   post_finaldef_aver  , &
   &   pre_initspr_aver    , &
   &   initspr_aver        , &
   &   midspr_aver         , &
   &   finalspr_aver       , &
   &   post_finalspr_aver  , &
   &   pre_inity_aver      , &
   &   inity_aver          , &
   &   midy_aver           , &
   &   finaly_aver         , &
   &   post_finaly_aver    , &
   &   pre_initc_aver      , &
   &   initc_aver          , &
   &   midc_aver           , &
   &   finalc_aver         , &
   &   post_finalc_aver
!19jun17
!21jun17    integer :: maxlengthdef, tdefevent
!21jun17    real(prec), allocatable :: y_defevent(:), z_defevent(:), &
!21jun17        & a_defevent(:), b_defevent(:), &
!21jun17        & spread_defevent(:), partdef_defevent(:)
!21jun17    integer, allocatable  :: nsurvivedef(:)




    write(outfile1,*) '******************************************'
    write(outfile1,*) ' SLOPE COEFFICIENTS OF  PARTIAL DEF '


! ---------------------------------------
! .. Default against lenght of default ..
! ---------------------------------------

!  construct regression objects
 allocate(x_mat(ndefcount,2),y_mat(ndefcount))
 x_mat(1:ndefcount,1)=one

! x_mat(1:ndefcount,2)=real(lengthdef(1:ndefcount))
! y_mat(1:ndefcount)=averdef(1:ndefcount)
! call OLS(ndefcount,2,x_mat,y_mat,beta)

    write(outfile1,*)
    write(outfile1,*) 'number of episodes', ndefcount, 'perods', ntime

!14feb17
! length default episode; corr part def - length episode
    length_aver=sum(lengthdef(1:ndefcount))/real(ndefcount)
    def_aver=sum(averdef(1:ndefcount))/real(ndefcount)
    length_sd=sqrt(sum((lengthdef(1:ndefcount)-length_aver)*(lengthdef(1:ndefcount)-length_aver))/real(ndefcount))
    def_sd=sqrt(sum((averdef(1:ndefcount)-def_aver)*(averdef(1:ndefcount)-def_aver))/real(ndefcount))
    corr_dlength=  ( sum(((averdef(1:ndefcount))-def_aver)*(lengthdef(1:ndefcount)-length_aver))/ &
            & real(ndefcount))/(def_sd*length_sd)
    allocate(rlengthdef(ndefcount)) !12may18
    rlengthdef=real(lengthdef)!12may18
    call Percentile(ndefcount,rlengthdef,0.50_prec,length_median)   !12may18
    deallocate(rlengthdef)

!14jun17
    spr_aver=sum(averspr(1:ndefcount))/real(ndefcount)
    spr_sd=sqrt(sum((averspr(1:ndefcount)-spr_aver) &
        &   *(averspr(1:ndefcount)-spr_aver))/real(ndefcount))
    corr_sprlength=( sum(((averspr(1:ndefcount))-spr_aver) &
        &                *(lengthdef(1:ndefcount)-length_aver))/ &
            & real(ndefcount))/(spr_sd*length_sd)

!22jun17
! Create: averdebttoy(1:ndefcount)
! Define: debttoy_aver, debttoy_sd, corr_debttoylength
   debttoy_aver=sum(averdebttoy(1:ndefcount))/real(ndefcount)
   debttoy_sd=sqrt(sum((averdebttoy(1:ndefcount)-debttoy_aver) &
        &   *(averdebttoy(1:ndefcount)-debttoy_aver))/real(ndefcount))
   corr_debttoylength=( sum(((averdebttoy(1:ndefcount))-debttoy_aver) &
        &                *(lengthdef(1:ndefcount)-length_aver))/ &
            & real(ndefcount))/(debttoy_sd*length_sd)
! Create: avery(1:ndefcount)
! Define: y_aver, y_sd, corr_ylength
   y_aver=sum(avery(1:ndefcount))/real(ndefcount)
   y_sd=sqrt(sum((avery(1:ndefcount)-y_aver) &
        &   *(avery(1:ndefcount)-y_aver))/real(ndefcount))
   corr_ylength=( sum(((avery(1:ndefcount))-y_aver) &
        &                *(lengthdef(1:ndefcount)-length_aver))/ &
            & real(ndefcount))/(y_sd*length_sd)

    pre_initdebttoy_aver    = sum(pre_initdebttoy   (1:ndefcount))/real(ndefcount)
    initdebttoy_aver        = sum(initdebttoy       (1:ndefcount))/real(ndefcount)
    middebttoy_aver         =sum(middebttoy         (1:ndefcount))/real(ndefcount)
    finaldebttoy_aver       = sum(finaldebttoy      (1:ndefcount))/real(ndefcount)
    post_finaldebttoy_aver  = sum(post_finaldebttoy (1:ndefcount))/real(ndefcount)
    pre_initdebttoy_aver    =pre_initdebttoy_aver/((one-q0*delta)*modelfreq)
    initdebttoy_aver        =initdebttoy_aver/((one-q0*delta)*modelfreq)
    middebttoy_aver         =middebttoy_aver/((one-q0*delta)*modelfreq)
    finaldebttoy_aver       =finaldebttoy_aver/((one-q0*delta)*modelfreq)
    post_finaldebttoy_aver  =post_finaldebttoy_aver/((one-q0*delta)*modelfreq)

    pre_initdef_aver    = sum(pre_initdef       (1:ndefcount))/real(ndefcount)
    initdef_aver        = sum(initdef       (1:ndefcount))/real(ndefcount)
    middef_aver         = sum(middef        (1:ndefcount))/real(ndefcount)
    finaldef_aver       = sum(finaldef      (1:ndefcount))/real(ndefcount)
    post_finaldef_aver  = sum(post_finaldef (1:ndefcount))/real(ndefcount)
    pre_initspr_aver    = sum(pre_initspr   (1:ndefcount))/real(ndefcount)
    initspr_aver        = sum(initspr       (1:ndefcount))/real(ndefcount)
    midspr_aver         = sum(midspr        (1:ndefcount))/real(ndefcount)
    finalspr_aver       = sum(finalspr      (1:ndefcount))/real(ndefcount)
    post_finalspr_aver  = sum(post_finalspr (1:ndefcount))/real(ndefcount)
    pre_inity_aver      = sum(pre_inity     (1:ndefcount))/real(ndefcount)
    inity_aver          = sum(inity         (1:ndefcount))/real(ndefcount)
    midy_aver           = sum(midy          (1:ndefcount))/real(ndefcount)
    finaly_aver         = sum(finaly        (1:ndefcount))/real(ndefcount)
    post_finaly_aver    = sum(post_finaly   (1:ndefcount))/real(ndefcount)
    pre_initc_aver      = sum(pre_initc     (1:ndefcount))/real(ndefcount)
    initc_aver          = sum(initc         (1:ndefcount))/real(ndefcount)
    midc_aver           = sum(midc          (1:ndefcount))/real(ndefcount)
    finalc_aver         = sum(finalc        (1:ndefcount))/real(ndefcount)
    post_finalc_aver    = sum(post_finalc   (1:ndefcount))/real(ndefcount)

!25jul18
!Create averhairc(1:ndefcount-1)
! Define: hairc_aver, hairc_sd, corr_hairclength
    hairc_aver=sum(averhairc(1:ndefcount-1))/real(ndefcount-1)
    hairc_sd=sqrt(sum((averhairc(1:ndefcount-1)-hairc_aver) &
        &   *(averhairc(1:ndefcount-1)-hairc_aver))/real(ndefcount-1))
    corr_hairclength=( sum(((averhairc(1:ndefcount-1))-hairc_aver) &
        &                *(lengthdef(1:ndefcount-1)-length_aver))/ &
            & real(ndefcount-1))/(hairc_sd*length_sd)

    write(outfile1,*) 'aver length of episodes', length_aver
    write(outfile1,*) 'median length of episodes', length_median !12may18
    write(outfile1,*) 'sd of length', length_sd !14jun17
    write(outfile1,*) 'aver def during episodes', def_aver
    write(outfile1,*) 'corr def - length of episode', corr_dlength
    write(outfile1,*) 'corr spr - length of episode', corr_sprlength !14jun17
    write(outfile1,*) 'corr debt-to-Y - length of episode', corr_debttoylength !22jun17
    write(outfile1,*) 'corr logy - length of episode', corr_ylength !22jun17
    write(outfile1,*) 'corr hairc - length of episode', corr_hairclength !25jul18

    write(outfile1,*) !10jan19
    write(outfile1,*) 'pre_init   debt '  ,   pre_initdebttoy_aver   *100._prec
    write(outfile1,*) 'init       debt '  ,   initdebttoy_aver       *100._prec
    write(outfile1,*) 'mid        debt '  ,   middebttoy_aver        *100._prec
    write(outfile1,*) 'final      debt '  ,   finaldebttoy_aver      *100._prec
    write(outfile1,*) 'post_final debt '  ,   post_finaldebttoy_aver *100._prec
    write(outfile1,*)
    write(outfile1,*) 'pre_init   def '  ,   pre_initdef_aver        *100._prec
    write(outfile1,*) 'init       def '  ,   initdef_aver            *100._prec
    write(outfile1,*) 'mid        def '  ,   middef_aver             *100._prec
    write(outfile1,*) 'final      def '  ,   finaldef_aver           *100._prec
    write(outfile1,*) 'post_final def '  ,   post_finaldef_aver      *100._prec
    write(outfile1,*)
    write(outfile1,*) 'pre_init   spr '  ,   pre_initspr_aver        *100._prec
    write(outfile1,*) 'init       spr '  ,   initspr_aver            *100._prec
    write(outfile1,*) 'mid        spr '  ,   midspr_aver             *100._prec
    write(outfile1,*) 'final      spr '  ,   finalspr_aver           *100._prec
    write(outfile1,*) 'post_final spr '  ,   post_finalspr_aver      *100._prec
    write(outfile1,*)
    write(outfile1,*) 'pre_init   log y '  ,   pre_inity_aver        *100._prec
    write(outfile1,*) 'init       log y '  ,   inity_aver            *100._prec
    write(outfile1,*) 'mid        log y '  ,   midy_aver             *100._prec
    write(outfile1,*) 'final      log y '  ,   finaly_aver           *100._prec
    write(outfile1,*) 'post_final log y '  ,   post_finaly_aver      *100._prec
    write(outfile1,*)
    write(outfile1,*) 'pre_init   log c '  ,   pre_initc_aver        *100._prec
    write(outfile1,*) 'init       log c '  ,   initc_aver            *100._prec
    write(outfile1,*) 'mid        log c '  ,   midc_aver             *100._prec
    write(outfile1,*) 'final      log c '  ,   finalc_aver           *100._prec
    write(outfile1,*) 'post_final log c '  ,   post_finalc_aver      *100._prec

!    write(outfile1,*)
!    write(outfile1,*) ' Slope partdef on lenght ', beta(2)


! the other way
 x_mat(1:ndefcount,2)=averdef(1:ndefcount)
 y_mat(1:ndefcount)=real(lengthdef(1:ndefcount))
 call OLS(ndefcount,2,x_mat,y_mat,beta)
 write(outfile1,*)
 write(outfile1,*) ' Slope of length on partdef ', beta(2)

 deallocate(x_mat,y_mat)

! ---------------------------------------
! .. Spread on partial default ..
! ---------------------------------------

 allocate(x_mat(ntime,2),y_mat(ntime))
 x_mat(1:ntime,1)=one

! x_mat(1:ntime,2)=spread(1:ntime)
! y_mat(1:ntime)=partdef(1:ntime)
!
! call OLS(ntime,2,x_mat,y_mat,beta)
!
!   write(outfile1,*)
!    write(outfile1,*) ' Slope partdef on spread ', beta(2)

 ! the other way
    x_mat(1:ntime,2)=partdef(1:ntime)
    y_mat(1:ntime)=spread(1:ntime)
    call OLS(ntime,2,x_mat,y_mat,beta)
    write(outfile1,*) ' Slope of spread on partdef  ', beta(2)

 deallocate(x_mat,y_mat)

! ---------------------------------------
! .. Output on partial default ..
! ---------------------------------------
 allocate(x_mat(ntime,2),y_mat(ntime))
 x_mat(1:ntime,1)=one

! x_mat(1:ntime,2)=y(1:ntime)
! y_mat(1:ntime)=partdef(1:ntime)
!
! call OLS(ntime,2,x_mat,y_mat,beta)
!
!    write(outfile1,*)
!    write(outfile1,*) ' Slope partdef on output ', beta(2)

 ! the other way around
 x_mat(1:ntime,1)=one
 x_mat(1:ntime,2)=partdef(1:ntime)

 y_mat(1:ntime)=y(1:ntime)

 call OLS(ntime,2,x_mat,y_mat,beta)
 write(outfile1,*) ' Slope output on partdef  ', beta(2)

 deallocate(x_mat,y_mat)
! ---------------------------------------
! .. Debt on partial default ..
! ---------------------------------------
 allocate(x_mat(ntime,2),y_mat(ntime))
 x_mat(1:ntime,1)=one
 x_mat(1:ntime,1)=one
 x_mat(1:ntime,2)=partdef(1:ntime)

 y_mat(1:ntime)=a(1:ntime)/y(1:ntime)

 call OLS(ntime,2,x_mat,y_mat,beta)

 write(outfile1,*) ' Slope debt/Y on partdef  ', beta(2)

 deallocate(x_mat,y_mat)


!10feb21
    length_aver_stat         =       length_aver
    length_sd_stat           =       length_sd
    corr_dlength_stat        =       corr_dlength
    corr_hairclength_stat    =       corr_hairclength

    pre_initdebttoy_aver_stat    =   pre_initdebttoy_aver
    initdebttoy_aver_stat        =   initdebttoy_aver
    middebttoy_aver_stat         =   middebttoy_aver
    finaldebttoy_aver_stat       =   finaldebttoy_aver
    post_finaldebttoy_aver_stat  =   post_finaldebttoy_aver

    pre_initdef_stat   = pre_initdef_aver
    initdef_stat       = initdef_aver
    middef_stat        = middef_aver
    finaldef_stat      = finaldef_aver
    post_finaldef_stat = post_finaldef_aver
    pre_initspr_stat   = pre_initspr_aver
    initspr_stat       = initspr_aver
    midspr_stat        = midspr_aver
    finalspr_stat      = finalspr_aver
    post_finalspr_stat = post_finalspr_aver
    pre_inity_stat     = pre_inity_aver
    inity_stat         = inity_aver
    midy_stat          = midy_aver
    finaly_stat        = finaly_aver
    post_finaly_stat   = post_finaly_aver
    pre_initc_stat     = pre_initc_aver
    initc_stat         = initc_aver
    midc_stat          = midc_aver
    finalc_stat        = finalc_aver
    post_finalc_stat   = post_finalc_aver

 deallocate(lengthdef,averdef)
 deallocate(averspr)
 deallocate(averdebttoy,avery)
 deallocate(averhairc) !25jul18
 deallocate(initdebttoy, finaldebttoy, middebttoy) !10jan19
 deallocate(pre_initdebttoy, post_finaldebttoy) !09feb21
 deallocate(   &
   &   pre_initdef     , &
   &   initdef         , &
   &   middef          , &
   &   finaldef        , &
   &   post_finaldef   , &
   &   pre_initspr     , &
   &   initspr         , &
   &   midspr          , &
   &   finalspr        , &
   &   post_finalspr   , &
   &   pre_inity       , &
   &   inity           , &
   &   midy            , &
   &   finaly          , &
   &   post_finaly     , &
   &   pre_initc       , &
   &   initc           , &
   &   midc            , &
   &   finalc          , &
   &   post_finalc          )

end subroutine slope_coeffs

!-----------------------------------------------------------------------
SUBROUTINE OLS(n,k,x,y,beta)

!x is n x k
!y is n x 1
!beta is k x 1
IMPLICIT NONE
INTEGER, INTENT(in)		:: n,k
REAL(8), INTENT(in)		:: x(n,k),y(n)
REAL(8), INTENT(out)	:: beta(k)
REAL(8)					:: lxx(k,k),lxxinv(k,k)
INTEGER					:: ierr

lxx = matmul(transpose(x),x)
CALL InvertMatrix(lxx, lxxinv, k, ierr)
beta = matmul(lxxinv,matmul(transpose(x),y))

END SUBROUTINE OLS

!Subroutine to find the inverse of a square matrix
!Author : Louisda16th a.k.a Ashwith J. Rego
!Reference : Algorithm has been well explained in:
!http://math.uww.edu/~mcfarlat/inverse.htm
!http://www.tutor.ms.unimelb.edu.au/matrix/matrix_inverse.html
!-----------------------------------------------------------------------
SUBROUTINE InvertMatrix(matrix, inverse, n, errorflag)
	!USE Parameters	!added by Greg 2/28/11 so that Display can be used to control output of errors

	IMPLICIT NONE
	!Declarations
	INTEGER, INTENT(IN)  :: n
	INTEGER, INTENT(OUT) :: errorflag  !Return error status. -1 for error, 0 for normal
	REAL(8), INTENT(IN)	:: matrix(n,n)  !Input matrix
	REAL(8), INTENT(OUT)	:: inverse(n,n) !Inverted matrix
	
	LOGICAL :: FLAG = .TRUE.
	INTEGER :: i, j, k
	REAL(8) :: m
	REAL(8), DIMENSION(n,2*n) :: augmatrix !augmented matrix
	
	!Augment input matrix with an identity matrix
	DO i = 1, n
		DO j = 1, 2*n
			IF (j <= n ) THEN
				augmatrix(i,j) = matrix(i,j)
			ELSE IF ((i+n) == j) THEN
				augmatrix(i,j) = 1
			Else
				augmatrix(i,j) = 0
			ENDIF
		END DO
	END DO
	
	!Reduce augmented matrix to upper traingular form
	DO k =1, n-1
		IF (augmatrix(k,k) == 0) THEN
			FLAG = .FALSE.
			DO i = k+1, n
				IF (augmatrix(i,k) /= 0) THEN
					DO j = 1,2*n
						augmatrix(k,j) = augmatrix(k,j)+augmatrix(i,j)
					END DO
					FLAG = .TRUE.
					EXIT
				ENDIF
				IF (FLAG .EQV. .FALSE.) THEN
					!IF(Display>0) PRINT*, "Matrix is non - invertible"
					inverse = 0
					errorflag = -1
					return
				ENDIF
			END DO
		ENDIF
		DO j = k+1, n			
			m = augmatrix(j,k)/augmatrix(k,k)
			DO i = k, 2*n
				augmatrix(j,i) = augmatrix(j,i) - m*augmatrix(k,i)
			END DO
		END DO
	END DO
	
	!Test for invertibility
	DO i = 1, n
		IF (augmatrix(i,i) == 0) THEN
			!IF(Display>0) PRINT*, "Matrix is non - invertible"
			inverse = 0
			errorflag = -1
			return
		ENDIF
	END DO
	
	!Make diagonal elements as 1
	DO i = 1 , n
		m = augmatrix(i,i)
		DO j = i , (2 * n)				
			   augmatrix(i,j) = (augmatrix(i,j) / m)
		END DO
	END DO
	
	!Reduced right side half of augmented matrix to identity matrix
	DO k = n-1, 1, -1
		DO i =1, k
		m = augmatrix(i,k+1)
			DO j = k, (2*n)
				augmatrix(i,j) = augmatrix(i,j) -augmatrix(k+1,j) * m
			END DO
		END DO
	END DO				
	
	!store answer
	DO i =1, n
		DO j = 1, n
			inverse(i,j) = augmatrix(i,j+n)
		END DO
	END DO
	errorflag = 0
END SUBROUTINE InvertMatrix

!!*! *****************************************************
!!*!01apr17
!!*subroutine split_by_default
!!*use Percentile_mod
!!*implicit none
!!*integer :: j, jj, ndefgtzero
!!*real(prec), dimension(2) :: pc, qdef
!!*real(prec), allocatable :: partdef_gtzero(:)
!!*real(prec), allocatable :: partdef1(:), partdef2(:), partdef3(:), partdef0(:)
!!*real(prec), allocatable :: spread1(:), spread2(:), spread3(:), spread0(:)
!!*real(prec), allocatable :: a1(:), a2(:), a3(:), a0(:)
!!*real(prec), allocatable :: y1(:), y2(:), y3(:), y0(:)
!!*integer :: j0, j1, j2, j3
!!*
!!*    write(outfile1,*) ' ***********************************'
!!*    write(outfile1,*) ' 25-75 PARTIAL DEF PERCENTILES '
!!*    write(outfile1,*) ' ***********************************'
!!*
!!*! .. Find percentile values ..
!!*
!!*    ndefgtzero=count(partdef(1:ntime).gt.small)
!!*    allocate(partdef_gtzero(ndefgtzero))
!!*
!!*    print*,ndefgtzero
!!*    jj=0
!!*    do j=1, ntime
!!*     if(partdef(j).gt.small) then
!!*        jj=jj+1
!!*        partdef_gtzero(jj)=partdef(j)
!!*     end if
!!*    end do
!!*    print*, jj
!!*
!!*    pc=(/.25_prec, .75_prec/)
!!*
!!*    do  j=1,2
!!*     call Percentile(ndefgtzero,partdef_gtzero,pc(j),qdef(j))
!!*    end do
!!*
!!*    write(outfile1,*) '25 and 75 percentiles '
!!*    write(outfile1,*) 'pc', pc
!!*    write(outfile1,*) 'qdef', qdef
!!*
!!*
!!*! ..  Create subsamples ..
!!*
!!*    allocate(partdef1(ndefgtzero), partdef2(ndefgtzero), partdef3(ndefgtzero))
!!*    allocate(spread1(ndefgtzero), spread2(ndefgtzero), spread3(ndefgtzero))
!!*    allocate(a1(ndefgtzero), a2(ndefgtzero), a3(ndefgtzero))
!!*    allocate(y1(ndefgtzero), y2(ndefgtzero), y3(ndefgtzero))
!!*    allocate(partdef0(ntime-ndefgtzero))
!!*    allocate(spread0(ntime-ndefgtzero))
!!*    allocate(a0(ntime-ndefgtzero))
!!*    allocate(y0(ntime-ndefgtzero))
!!*
!!*    ! .. subsample counters ..
!!*    j0=0
!!*    j1=0
!!*    j2=0
!!*    j3=0
!!*
!!*    do j=1, ntime
!!*     if((partdef(j).gt.small).and.(partdef(j).le.qdef(1))) then
!!*        j1=j1+1
!!*        y1(j1)=y(j)
!!*        a1(j1)=a(j)
!!*        spread1(j1)=spread(j)
!!*        partdef1(j1)=partdef(j)
!!*     else if((partdef(j).gt.qdef(1)).and.(partdef(j).le.qdef(2))) then
!!*        j2=j2+1
!!*        y2(j2)=y(j)
!!*        a2(j2)=a(j)
!!*        spread2(j2)=spread(j)
!!*        partdef2(j2)=partdef(j)
!!*     else if((partdef(j).gt.qdef(2))) then
!!*        j3=j3+1
!!*        y3(j3)=y(j)
!!*        a3(j3)=a(j)
!!*        spread3(j3)=spread(j)
!!*        partdef3(j3)=partdef(j)
!!*     else if((partdef(j).le.small)) then
!!*        j0=j0+1
!!*        y0(j0)=y(j)
!!*        a0(j0)=a(j)
!!*        spread0(j0)=spread(j)
!!*        partdef0(j0)=partdef(j)
!!*     end if
!!*    end do
!!*
!!*    ifsmalldef=0 !11may18
!!*    write(outfile1,*)
!!*    write(outfile1,*) ' Means 0 default '
!!*    call report_means(j0,y0,a0,spread0,partdef0)
!!*    ifsmalldef=1 !11may18
!!*    write(outfile1,*)
!!*    write(outfile1,*) ' Means 0-25 quantile '
!!*    call report_means(j1,y1,a1,spread1,partdef1)
!!*    ifsmalldef=0 !11may18
!!*    write(outfile1,*)
!!*    write(outfile1,*) ' Means 25-75 quantile '
!!*    call report_means(j2,y2,a2,spread2,partdef2)
!!*    write(outfile1,*)
!!*    write(outfile1,*) ' Means 75-100 quantile '
!!*    call report_means(j3,y3,a3,spread3,partdef3)
!!*
!!*deallocate(partdef_gtzero,partdef1,partdef2,partdef3, partdef0)
!!*deallocate(spread1,spread2,spread3,spread0)
!!*deallocate(a1,a2,a3,a0)
!!*deallocate(y1,y2,y3,y0)
!!*
!!*end subroutine split_by_default
!!*
!!*!*************************************************************************
!!*!01apr17
!!* subroutine report_means(ntime,y,a,spread,partdef)
!!* implicit none
!!* integer :: ntime
!!*
!!*! Local out: logy_diff, logz_diff, AtoY, DebttoY, freqdef,arrears, Spr
!!*! Local dummy in: ntime, y,z,a,d, spread, partdef
!!*
!!*real(prec), dimension(ntime) :: y,a,spread,partdef
!!*real(prec):: logy_diff, AtoY, DebttoY, freqdef,arrears, Spr
!!*
!!* ! .. Statistics ..
!!*    logy_diff=sum(log(y(1:ntime))-log(y_aver))/real(ntime)
!!*!    logz_diff=sum(log(z(1:ntime))-z_aver)/real(ntime)
!!*    AtoY=sum(a(1:ntime)/y(1:ntime))/real(ntime) !23jun17 (sum(a(1:ntime))/real(ntime))/(sum(y(1:ntime))/real(ntime))
!!*    DebttoY=(sum(a(1:ntime)/y(1:ntime))/real(ntime))/((one-q0*delta)*modelfreq)
!!*    freqdef=real(count(d(1:ntime).gt.zero+small))/real(ntime)
!!*    arrears= sum(partdef(1:ntime))/real(ntime)
!!*        ! sum(d(1:ntime)/a(1:ntime),d(1:ntime).gt.zero+small)/real(count(d(1:ntime).gt.zero+small))
!!*    Spr=sum(spread(1:ntime))/real(ntime)
!!*
!!*    write(outfile1,'(a30,f9.5)') 'dev log y from mean ', logy_diff
!!*!    write(outfile1,'(a30,f9.5)') 'dev log z from mean ', logz_diff
!!*    write(outfile1,'(a30,f9.5)') 'Debt due  to Y ', AtoY
!!*    write(outfile1,'(a30,f9.5)') 'Total Debt to Y ', DebttoY
!!*!    write(outfile1,'(a30,f9.5)') 'Frequency defau ', freqdef
!!*    write(outfile1,'(a30,f9.5)') 'Partial default ', arrears
!!*    write(outfile1,'(a30,f9.5)') 'Spread ', Spr
!!*
!!*    if(ifsmalldef.eq.1) smalldef=arrears !11may18
!!*
!!*!    write(outfile1,'(4a6,a7,a2,6a8)')  'beta', 'jstar','phi1','gam','minPsi','¦', &
!!*!                                      & 'A/Y', 'freqdef','arrears', 'spread','defsd', 'sprsd'
!!*!    write(outfile1,'(f6.3,i6,f6.3,f6.3,f7.3,a2,6f8.4)') &
!!*!                                    & beta, jzstar, phi1,gamma_psi, Psimin, &
!!*!                                    & '¦', &
!!*!                                    & AtoY, freqdef,  arrears, Spr, d_stdv, spr_stdv
!!*
!!* end subroutine report_means
!***************************************************************************
subroutine split_by_default
use Percentile_mod
implicit none
integer :: j, jj, ndefgtzero
real(prec), dimension(2) :: pc, qdef
real(prec), allocatable :: partdef_gtzero(:)
real(prec), allocatable :: partdef1(:), partdef2(:), partdef3(:), partdef0(:)
real(prec), allocatable :: spread1(:), spread2(:), spread3(:), spread0(:)
real(prec), allocatable :: a1(:), a2(:), a3(:), a0(:)
real(prec), allocatable :: y1(:), y2(:), y3(:), y0(:)
integer :: j0, j1, j2, j3
real(prec), allocatable :: c1(:), c2(:), c3(:), c0(:)

    write(outfile1,*) ' ***********************************'
    write(outfile1,*) ' 25-75 PARTIAL DEF PERCENTILES '
    write(outfile1,*) ' ***********************************'

! .. Find percentile values ..

    ndefgtzero=count(partdef(1:ntime).gt.small)
    allocate(partdef_gtzero(ndefgtzero))

    print*,ndefgtzero
    jj=0
    do j=1, ntime
     if(partdef(j).gt.small) then
        jj=jj+1
        partdef_gtzero(jj)=partdef(j)
     end if
    end do
    print*, jj

    pc=(/.25_prec, .75_prec/)

    do  j=1,2
     call Percentile(ndefgtzero,partdef_gtzero,pc(j),qdef(j))
    end do

    write(outfile1,*) '25 and 75 percentiles '
    write(outfile1,*) 'pc', pc
    write(outfile1,*) 'qdef', qdef


! ..  Create subsamples ..

    allocate(partdef1(ndefgtzero), partdef2(ndefgtzero), partdef3(ndefgtzero))
    allocate(spread1(ndefgtzero), spread2(ndefgtzero), spread3(ndefgtzero))
    allocate(a1(ndefgtzero), a2(ndefgtzero), a3(ndefgtzero))
    allocate(y1(ndefgtzero), y2(ndefgtzero), y3(ndefgtzero))
    allocate(partdef0(ntime-ndefgtzero))
    allocate(spread0(ntime-ndefgtzero))
    allocate(a0(ntime-ndefgtzero))
    allocate(y0(ntime-ndefgtzero))

    allocate(c1(ndefgtzero), c2(ndefgtzero), c3(ndefgtzero))
    allocate(c0(ntime-ndefgtzero))

    ! .. subsample counters ..
    j0=0
    j1=0
    j2=0
    j3=0

    do j=1, ntime
     if((partdef(j).gt.small).and.(partdef(j).le.qdef(1))) then
        j1=j1+1
        y1(j1)=y(j)
        a1(j1)=a(j)
        spread1(j1)=spread(j)
        partdef1(j1)=partdef(j)
        c1(j1)=c(j)
     else if((partdef(j).gt.qdef(1)).and.(partdef(j).le.qdef(2))) then
        j2=j2+1
        y2(j2)=y(j)
        a2(j2)=a(j)
        spread2(j2)=spread(j)
        partdef2(j2)=partdef(j)
        c2(j2)=c(j)
     else if((partdef(j).gt.qdef(2))) then
        j3=j3+1
        y3(j3)=y(j)
        a3(j3)=a(j)
        spread3(j3)=spread(j)
        partdef3(j3)=partdef(j)
        c3(j3)=c(j)
     else if((partdef(j).le.small)) then
        j0=j0+1
        y0(j0)=y(j)
        a0(j0)=a(j)
        spread0(j0)=spread(j)
        partdef0(j0)=partdef(j)
        c0(j0)=c(j)
     end if
    end do

    ifsmalldef=0 !11may18
    write(outfile1,*)
    write(outfile1,*) ' Means 0 default '
    call report_means(j0,y0,a0,spread0,partdef0,c0)
    ifsmalldef=1 !11may18
    write(outfile1,*)
    write(outfile1,*) ' Means 0-25 quantile '
    call report_means(j1,y1,a1,spread1,partdef1,c1)
    ifsmalldef=0 !11may18
    write(outfile1,*)
    write(outfile1,*) ' Means 25-75 quantile '
    call report_means(j2,y2,a2,spread2,partdef2,c2)
    write(outfile1,*)
    write(outfile1,*) ' Means 75-100 quantile '
    call report_means(j3,y3,a3,spread3,partdef3,c3)

deallocate(partdef_gtzero,partdef1,partdef2,partdef3, partdef0)
deallocate(spread1,spread2,spread3,spread0)
deallocate(c1,c2,c3,c0)
deallocate(a1,a2,a3,a0)
deallocate(y1,y2,y3,y0)

end subroutine split_by_default
! ***************************************************************
 subroutine report_means(ntime,y,a,spread,partdef,c)
 implicit none
 integer :: ntime

! Local out: logy_diff, logz_diff, AtoY, DebttoY, freqdef,arrears, Spr
! Local dummy in: ntime, y,z,a,d, spread, partdef

real(prec), dimension(ntime) :: y,a,spread,partdef,c
real(prec):: logy_diff, AtoY, DebttoY, freqdef,arrears, Spr, logc_diff

 ! .. Statistics ..
    logy_diff=sum(log(y(1:ntime))-log(y_aver))/real(ntime)
!    logz_diff=sum(log(z(1:ntime))-z_aver)/real(ntime)
    AtoY=sum(a(1:ntime)/y(1:ntime))/real(ntime) !23jun17 (sum(a(1:ntime))/real(ntime))/(sum(y(1:ntime))/real(ntime))
    DebttoY=(sum(a(1:ntime)/y(1:ntime))/real(ntime))/((one-q0*delta)*modelfreq)
    freqdef=real(count(d(1:ntime).gt.zero+small))/real(ntime)
    arrears= sum(partdef(1:ntime))/real(ntime)
        ! sum(d(1:ntime)/a(1:ntime),d(1:ntime).gt.zero+small)/real(count(d(1:ntime).gt.zero+small))
    Spr=sum(spread(1:ntime))/real(ntime)
    logc_diff=sum(log(c(1:ntime))-log(cons_aver))/real(ntime)

    write(outfile1,'(a30,f9.5)') 'dev log y from mean ', logy_diff
!    write(outfile1,'(a30,f9.5)') 'dev log z from mean ', logz_diff
    write(outfile1,'(a30,f9.5)') 'Debt due  to Y ', AtoY
    write(outfile1,'(a30,f9.5)') 'Total Debt to Y ', DebttoY
!    write(outfile1,'(a30,f9.5)') 'Frequency defau ', freqdef
    write(outfile1,'(a30,f9.5)') 'Partial default ', arrears
    write(outfile1,'(a30,f9.5)') 'Spread ', Spr
    write(outfile1,'(a30,f9.5)') 'Consumption ', logc_diff

    if(ifsmalldef.eq.1) smalldef=arrears !11may18

!    write(outfile1,'(4a6,a7,a2,6a8)')  'beta', 'jstar','phi1','gam','minPsi','¦', &
!                                      & 'A/Y', 'freqdef','arrears', 'spread','defsd', 'sprsd'
!    write(outfile1,'(f6.3,i6,f6.3,f6.3,f7.3,a2,6f8.4)') &
!                                    & beta, jzstar, phi1,gamma_psi, Psimin, &
!                                    & '¦', &
!                                    & AtoY, freqdef,  arrears, Spr, d_stdv, spr_stdv

 end subroutine report_means
! *****************************************************************
!10feb21
subroutine final_stats
implicit none

!open(47, file='final_stats.dat') !10feb21
!write(47,*) 'QUARTERLY DATA'
! [report_stats]
    write(47,'(a25,f9.4)') 'Sd log inc ', sqrt(logy_var)
    write(47,'(a25,f9.4)') 'Autocorr log inc ', logy_corr !26may15


   write(47,'(a30,a10,f9.5)') 'partial default', '(D/A)', arrears
   write(47,'(a30,a10,f9.5)') 'freq arrears>0', '  ', freqdef
   write(47,'(a30,a10,f9.5)') 'debt due/output', 'A/Y', (sum(a(1:ntime)/y(1:ntime))/real(ntime))
   write(47,'(a30,a10,f9.5)') 'spread ', ' ', (sum(spread(1:ntime) &
                & ) &
                & /real(ntime))
   write(47,'(a30,a10,f9.5)') 'debt/output' , ' ', &      !16jan15
                & (sum(a(1:ntime)/y(1:ntime)) &
                &       /real(ntime))/((one-q0*delta)*modelfreq) !23jun17


   ! location sensitive
   write(47,*)
   write(47,'(a30,a10,f9.5)') 'sd spread', '  ',    spr_stdv
   write(47,'(a30,a10,f9.5)') 'sd part default', '  ',    d_stdv !d_stdv_noncond
   write(47,'(a30,a10,f9.5)') 'sd debt /output', '  ',    &
    & debtdue_stdv/((one-q0*delta)*modelfreq) !14jun17
   write(47,'(a30,a10,f9.5)') 'sd debtdue /output', '  ',  debtdue_stdv
   write(47,'(a30,a10,f9.5)') 'corr y spread', '  ',          corrSpr
   write(47,'(a30,a10,f9.5)') 'corr spread debttoY', '  ', &
        & ( sum(((spread(1:ntime))-spr_aver)*((a(1:ntime)/y(1:ntime))-debtdue))/ &
        &   real(ntime) )/(spr_stdv*debtdue_stdv)   !14jun17

   write(47,'(a30,a10,f9.5)') 'corr partdefault spread', '  ',   corr_dspr
   write(47,'(a30,a10,f9.5)') 'corr partdefault logy', '  ',   corr_dy
   write(47,'(a30,a10,f9.5)') 'corr partdefault debttoY', '  ',   corr_ddebttoY

   write(47,*)
   write(47,'(a30,a10,f9.5)') 'coupon def/Y |def>0', '  ', coupdef_cond
   write(47,'(a30,a10,f9.5)') 'sd coupon def/Y |def>0', '  ', coupdef_cond_sd
   write(47,'(a30,a10,f9.5)') 'coupon def/Y', '  ', coupdef
   write(47,'(a30,a10,f9.5)') 'sd coupon def/Y', '  ', coupdef_sd
   write(47,'(a30,a10,f9.5)') 'debt service', '  ', debtserv
   write(47,'(a30,a10,f9.5)') 'sd debt service', '  ', debtserv_sd

! [haircuts_extensions]
   write(47,*)
    write(47,'(a25,f9.4)') 'haircut',  haircut_stat
    write(47,'(a25,f9.4)') 'extension', extension_stat


! [slope_coeff]

    write(47,'(a25,f9.4)') 'aver length of episodes', length_aver_stat
    write(47,'(a25,f9.4)') 'sd of length', length_sd_stat
    write(47,'(a25,f9.4)') 'corr def - length of episode', corr_dlength_stat
    write(47,'(a25,f9.4)') 'corr hairc - length of episode', corr_hairclength_stat
    write(47,*)
    write(47,'(a25,f9.4)') 'pre_init debt ', pre_initdebttoy_aver_stat
    write(47,'(a25,f9.4)') 'init debt ', initdebttoy_aver_stat
    write(47,'(a25,f9.4)') 'mid debt ',  middebttoy_aver_stat
    write(47,'(a25,f9.4)') 'final debt ', finaldebttoy_aver_stat
    write(47,'(a25,f9.4)') 'post_final debt ', post_finaldebttoy_aver_stat
    write(47,*)
    write(47,'(a25,f9.4)')  ' pre_initdef_stat  ',       pre_initdef_stat
    write(47,'(a25,f9.4)')  ' initdef_stat      ',       initdef_stat
    write(47,'(a25,f9.4)')  ' middef_stat       ',       middef_stat
    write(47,'(a25,f9.4)')  ' finaldef_stat     ',       finaldef_stat
    write(47,'(a25,f9.4)')  ' post_finaldef_stat',       post_finaldef_stat
    write(47,*)
    write(47,'(a25,f9.4)')  ' pre_initspr_stat  ',       pre_initspr_stat
    write(47,'(a25,f9.4)')  ' initspr_stat      ',       initspr_stat
    write(47,'(a25,f9.4)')  ' midspr_stat       ',       midspr_stat
    write(47,'(a25,f9.4)')  ' finalspr_stat     ',       finalspr_stat
    write(47,'(a25,f9.4)')  ' post_finalspr_stat',       post_finalspr_stat
    write(47,*)
    write(47,'(a25,f9.4)')  ' pre_inity_stat    ',       pre_inity_stat
    write(47,'(a25,f9.4)')  ' inity_stat        ',       inity_stat
    write(47,'(a25,f9.4)')  ' midy_stat         ',       midy_stat
    write(47,'(a25,f9.4)')  ' finaly_stat       ',       finaly_stat
    write(47,'(a25,f9.4)')  ' post_finaly_stat  ',       post_finaly_stat
    write(47,*)
    write(47,'(a25,f9.4)')  ' pre_initc_stat    ',       pre_initc_stat
    write(47,'(a25,f9.4)')  ' initc_stat        ',       initc_stat
    write(47,'(a25,f9.4)')  ' midc_stat         ',       midc_stat
    write(47,'(a25,f9.4)')  ' finalc_stat       ',       finalc_stat
    write(47,'(a25,f9.4)')  ' post_finalc_stat  ',       post_finalc_stat

! [split_by_default]
    write(47,*)
    write(47,'(a25,f9.4)') 'small def  ',  smalldef

!close(47)

end subroutine final_stats

 end subroutine simul_paths

!*************************************************************
! [11.] 2D GRAPHS
!*************************************************************
 subroutine graph2d_params
 implicit none
  CHARACTER(*), PARAMETER :: fileplace = "/data/home/tew158/partdef/v21/calibration/calib22mpi/dataf/"
  open(297, file=fileplace//'d2param.dat')
  write(297,'(a14,a14,a14)') 'delta', 'q0', 'freq'
  write(297,'(f14.6,f14.6,f14.6)') delta, q0, modelfreq
  close(297)
 end subroutine graph2d_params

!11apr13
 subroutine graph2d_D
 implicit none
 character (len=2) :: jz_c
 do jz= 1,nz
 jy=locate_in_y(zj(jz))
 if(abs(yj(jy)-zj(jz)).gt.abs(yj(jy+1)-zj(jz))) jy=jy+1
!     write(jz_c,'(i1)') jz
     if(jz.lt.10) write(jz_c,'(i1)') jz !01apr14
     if(jz.ge.10) write(jz_c,'(i2)') jz
     open(297, file='d2D_z'//trim(jz_c)//'.dat')
     write(297,'(a14, f14.7)') 'Prod= ', zj(jz)
     write(297,'(a14,a14)') 'netdebt', 'def'
          do ja=1, nA
!            write(297,'(f9.4,f9.4)') Aj(ja), Dj(locDD(jy,ja,jz))*Aj(ja) !17apr14
!            write(297,'(f14.4,f14.4)') Aj(ja), D_c(jy,ja,jz)*Aj(ja) !16aug14
            write(297,'(f14.4,f14.4)') Aj(ja)/zaver_glob, D_c(jy,ja,jz) !16jun17
          end do
     close(297)
 end do
 end subroutine graph2d_D


subroutine graph2d_Doffgrid !07feb15
 use interp
 implicit none
 character (len=2) :: jz_c
 real(prec) :: ddum, adum, vtemp_ND, vtemp_D
 integer :: jalow, jaup
 do jz= 1,nz
 jy=locate_in_y(zj(jz))
 if(abs(yj(jy)-zj(jz)).gt.abs(yj(jy+1)-zj(jz))) jy=jy+1
!     write(jz_c,'(i1)') jz
     if(jz.lt.10) write(jz_c,'(i1)') jz !01apr14
     if(jz.ge.10) write(jz_c,'(i2)') jz
     open(297, file='d2Doff_z'//trim(jz_c)//'.dat')
     write(297,'(a14, f14.7)') 'Prod= ', zj(jz)
     write(297,'(a14,a14)') 'netdebt', 'def'

 adum=zero
 do while (adum.le.Aj(nA))
    jalow=count(Aj.le.adum)
    jaup=min(jalow+1,nA)
   if(D01(jy,jalow,jz).eq.1) then   !default
    ddum= lip(Aj,DD_c(jy,:,jz),adum)*adum
   else if (D01(jy,jaup,jz).eq.0) then       !no-default
    ddum= zero
   else
    vtemp_ND=lip(Aj,vND(jy,:,jz),adum)
    vtemp_D =lip(Aj, vD(jy,:,jz),adum)
    if ( vtemp_ND.ge.vtemp_D) then
     ddum= zero
    else
     ddum= lip(Aj,DD_c(jy,:,jz),adum)*adum
    end if
   end if
   write(297,'(f14.4,f14.4)') adum, ddum
   adum=adum+.0005
 end do
     close(297)
 end do
 end subroutine graph2d_Doffgrid

 subroutine graph2d_D01
 implicit none
 character (len=2) :: jz_c
 do jz= 1,nz
 jy=locate_in_y(zj(jz))
 if(abs(yj(jy)-zj(jz)).gt.abs(yj(jy+1)-zj(jz))) jy=jy+1
!     write(jz_c,'(i1)') jz
     if(jz.lt.10) write(jz_c,'(i1)') jz !01apr14
     if(jz.ge.10) write(jz_c,'(i2)') jz
     open(297, file='d2D01_z'//trim(jz_c)//'.dat')
     write(297,'(a14, f14.7)') 'Prod= ', zj(jz)
     write(297,'(a14,a14)') 'netdebt', 'def01'
          do ja=1, nA
!            write(297,'(f9.4,f9.4)') Aj(ja), Dj(locDD(jy,ja,jz))*Aj(ja) !17apr14
            write(297,'(f14.4,i3)') Aj(ja), D01(jy,ja,jz)
          end do
     close(297)
 end do
 end subroutine graph2d_D01

 subroutine graph2d_BD
 implicit none
 character (len=2) :: jz_c
 do jz= 1,nz
 jy=locate_in_y(zj(jz))
 if(abs(yj(jy)-zj(jz)).gt.abs(yj(jy+1)-zj(jz))) jy=jy+1
!     write(jz_c,'(i1)') jz
     if(jz.lt.10) write(jz_c,'(i1)') jz !01apr14
     if(jz.ge.10) write(jz_c,'(i2)') jz
     open(297, file='d2BD_z'//trim(jz_c)//'.dat')
     write(297,'(a14, f14.7)') 'Prod= ', zj(jz)
     write(297,'(a14,a14)') 'netdebt', 'borrow'
          do ja=1, nA
!            write(297,'(f14.4,f14.4)') Aj(ja), Bj(locBD(jy,ja,jz))
            write(297,'(f14.4,f14.4)') Aj(ja), BD_c(jy,ja,jz) !16aug14
          end do
     close(297)
 end do
 end subroutine graph2d_BD

 subroutine graph2d_BND
 implicit none
 character (len=2) :: jz_c
 do jz= 1,nz
 jy=locate_in_y(zj(jz))
 if(abs(yj(jy)-zj(jz)).gt.abs(yj(jy+1)-zj(jz))) jy=jy+1
!     write(jz_c,'(i1)') jz
     if(jz.lt.10) write(jz_c,'(i1)') jz !01apr14
     if(jz.ge.10) write(jz_c,'(i2)') jz
     open(297, file='d2BND_z'//trim(jz_c)//'.dat')
     write(297,'(a14, f14.7)') 'Prod= ', zj(jz)
     write(297,'(a14,a14)') 'netdebt', 'borrow'
          do ja=1, nA
!            write(297,'(f14.4,f14.4)') Aj(ja), Bj(locBD(jy,ja,jz))
            write(297,'(f14.4,f14.4)') Aj(ja), BND_c(jy,ja,jz) !16aug14
          end do
     close(297)
 end do
 end subroutine graph2d_BND


 subroutine graph2d_Q
 implicit none
 character (len=2) :: jz_c
 integer :: jdef
 CHARACTER(*), PARAMETER :: fileplace = "/data/home/tew158/partdef/v21/calibration/calib22mpi/dataf/"
!04apr17
 !jdef=count(Dj.lt.0.53_prec)
 jdef=nD

 do jz= 1,nz
!     write(jz_c,'(i1)') jz
     if(jz.lt.10) write(jz_c,'(i1)') jz !01apr14
     if(jz.ge.10) write(jz_c,'(i2)') jz
     open(297, file=fileplace//'d2Q_z'//trim(jz_c)//'.dat')
     !open(297, file='d2Q_z'//trim(jz_c)//'.dat')
     write(297,'(a14, f14.7, a14, f14.7)') 'Prod= ', zj(jz), 'def >0 ', Dj(jdef) !04apr17
     write(297,'(a9,a9,a9)') 'newdebt', 'qqtil_d0', 'qqtil_d+'
          do ja=nAzero+1, nA
            write(297,'(f9.4,f9.4,f9.4)') Aj(ja)/zaver_glob, qqtil(ja,1,jz), qqtil(ja,jdef,jz) !04apr17
          end do
     close(297)
 end do
 end subroutine graph2d_Q

!10jul13
 subroutine graph2d_QD
 implicit none
 character (len=2) :: jz_c
 do jz= 1,nz
!     write(jz_c,'(i1)') jz
     if(jz.lt.10) write(jz_c,'(i1)') jz !01apr14
     if(jz.ge.10) write(jz_c,'(i2)') jz
     open(297, file='d2QD_z'//trim(jz_c)//'.dat')
     write(297,'(a14, f14.7)') 'Prod= ', zj(jz)
     write(297,'(a9,a9,a9,a9)') 'newdebt', 'qqtil_d0', 'qqtil_d3', 'qqtil_d15'
          do ja=nAzero+1, nA
            write(297,'(f9.4,f9.4,f9.4,f9.4)') Aj(ja), qqtil(ja,1,jz), qqtil(ja,3,jz), qqtil(ja,15,jz)
          end do
     close(297)
 end do
 end subroutine graph2d_QD

!!**!31mar14
!!** subroutine graph2d_barg
!!** use interp
!!**  character (len=2) :: jz_c
!!**  real(prec) :: ARpr
!!** do jz= 1,nz
!!** jy=locate_in_y(zj(jz))
!!** if(abs(yj(jy)-zj(jz)).gt.abs(yj(jy+1)-zj(jz))) jy=jy+1
!!**     if(jz.lt.10) write(jz_c,'(i1)') jz !01apr14
!!**     if(jz.ge.10) write(jz_c,'(i2)') jz
!!**     open(297, file='d2barg_z'//trim(jz_c)//'.dat')
!!**     write(297,'(a14, f14.7)') 'Prod= ', zj(jz)
!!**     write(297,'(a14,a14,a14,a14)') 'netdebt', 'AR', 'SB', 'SL'
!!**          do ja=nAzero+1, nA
!!**!11sep14
!!**    ARpr=blip(Bj(nBzero:nB),Dj,GammaAr(nBzero:nB,:,ja,jz),B_c(jy,ja,jz),D_c(jy,ja,jz))
!!**            write(297,'(f14.4,f14.4,f14.4,f14.4)') &
!!**    &  Aj(ja),     &
!!**    & ARpr,        &
!!**    & lininterp3(Aj(nAzero:nA),Bj(1:nB),Dj(1:nD),SB(nAzero:nA,1:nB,1:nD,ja,jz), &
!!**    &      ARpr,B_c(jy,ja,jz),D_c(jy,ja,jz)), &
!!**    & lininterp3(Aj(nAzero:nA),Bj(1:nB),Dj(1:nD),SL(nAzero:nA,1:nB,1:nD,ja,jz), &
!!**    &      ARpr,B_c(jy,ja,jz),D_c(jy,ja,jz))
!!**
!!**!    & SB_c(blip(Bj(nBzero:nB),Dj,GammaAr(nBzero:nB,:,ja,jz),B_c(jy,ja,jz),D_c(jy,ja,jz))), &
!!**!    & SL_c(blip(Bj(nBzero:nB),Dj,GammaAr(nBzero:nB,:,ja,jz),B_c(jy,ja,jz),D_c(jy,ja,jz)))
!!**!    SB(locGamm(locB(jy,ja,jz),locD(jy,ja,jz),ja,jz), &
!!**!            & locB(jy,ja,jz),locD(jy,ja,jz),ja,jz),         &
!!**!    SL(locGamm(locB(jy,ja,jz),locD(jy,ja,jz),ja,jz), &
!!**!            & locB(jy,ja,jz),locD(jy,ja,jz),ja,jz)
!!**
!!**!!            write(297,'(f14.4,f14.4,f14.4,f14.4)') Aj(ja),              &
!!**!!    Aj(locGamm(locB(jy,ja,jz),locD(jy,ja,jz),ja,jz)),       &
!!**!!    SB(locGamm(locB(jy,ja,jz),locD(jy,ja,jz),ja,jz), &
!!**!!            & locB(jy,ja,jz),locD(jy,ja,jz),ja,jz),         &
!!**!!    SL(locGamm(locB(jy,ja,jz),locD(jy,ja,jz),ja,jz), &
!!**!!            & locB(jy,ja,jz),locD(jy,ja,jz),ja,jz)
!!**          end do
!!**     close(297)
!!** end do
!!** end subroutine graph2d_barg

!07apr14
 subroutine graph2d_v
 implicit none
 character (len=2) :: jz_c
 do jz= 1,nz
 jy=locate_in_y(zj(jz))
 if(abs(yj(jy)-zj(jz)).gt.abs(yj(jy+1)-zj(jz))) jy=jy+1
     if(jz.lt.10) write(jz_c,'(i1)') jz
     if(jz.ge.10) write(jz_c,'(i2)') jz
     open(297, file='d2v_z'//trim(jz_c)//'.dat')
     write(297,'(a14, f14.7)') 'Prod= ', zj(jz)
     write(297,'(a14,a14)') 'netdebt', 'value'
          do ja=1, nA
            write(297,'(f14.4,f14.4)') Aj(ja), vD(jy,ja,jz)
          end do
     close(297)
 end do
 end subroutine graph2d_v

 subroutine graph2d_vND
 implicit none
 character (len=2) :: jz_c
 do jz= 1,nz
 jy=locate_in_y(zj(jz))
 if(abs(yj(jy)-zj(jz)).gt.abs(yj(jy+1)-zj(jz))) jy=jy+1
     if(jz.lt.10) write(jz_c,'(i1)') jz
     if(jz.ge.10) write(jz_c,'(i2)') jz
     open(297, file='d2vND_z'//trim(jz_c)//'.dat')
     write(297,'(a14, f14.7)') 'Prod= ', zj(jz)
     write(297,'(a14,a14)') 'netdebt', 'value'
          do ja=1, nA
            write(297,'(f14.4,f14.4)') Aj(ja), vND(jy,ja,jz)
          end do
     close(297)
 end do
 end subroutine graph2d_vND

 subroutine graph2d_H
 implicit none
 character (len=2) :: jz_c
 do jz= 1,nz
 jy=locate_in_y(zj(jz))
 if(abs(yj(jy)-zj(jz)).gt.abs(yj(jy+1)-zj(jz))) jy=jy+1
     if(jz.lt.10) write(jz_c,'(i1)') jz
     if(jz.ge.10) write(jz_c,'(i2)') jz
     open(297, file='d2H_z'//trim(jz_c)//'.dat')
     write(297,'(a14, f14.7)') 'Prod= ', zj(jz)
     write(297,'(a14,a14)') 'netdebt', 'value'
          do ja=1, nA
            write(297,'(f14.4,f14.4)') Aj(ja), H(jy,ja,jz)
          end do
     close(297)
 end do
 end subroutine graph2d_H

!!**!21may14
!!** subroutine graph2d_rr
!!** use interp
!!**  character (len=2) :: jz_c
!!** do jz= 1,nz
!!** jy=locate_in_y(zj(jz))
!!** if(abs(yj(jy)-zj(jz)).gt.abs(yj(jy+1)-zj(jz))) jy=jy+1
!!**     if(jz.lt.10) write(jz_c,'(i1)') jz !01apr14
!!**     if(jz.ge.10) write(jz_c,'(i2)') jz
!!**     open(297, file='d2rr_z'//trim(jz_c)//'.dat')
!!**     write(297,'(a14, f14.7)') 'Prod= ', zj(jz)
!!**     write(297,'(a14,a14)') 'netdebt', 'rr'
!!**!11sep14
!!**          do ja=nAzero+1, nA
!!**            write(297,'(f14.4,f14.4,f14.4,f14.4)') Aj(ja), &
!!**        & blip(Bj(nBzero:nB),Dj,rr(nBzero:nB,:,ja,jz),BD_c(jy,ja,jz),D_c(jy,ja,jz))
!!**!        & rr(locB(jy,ja,jz),locD(jy,ja,jz),ja,jz)
!!**          end do
!!**     close(297)
!!** end do
!!** end subroutine graph2d_rr


!29feb15
 subroutine graph2d_eps_Apr
 use interp
 implicit none
 integer :: jy, jyplus, jyminus
 real(prec) :: def, defplus, defminus,  &
    &   apr, aprplus, aprminus, &
    &   v, vplus, vminus, &
    &   b, bplus, bminus, &
    &   qqq, qqqplus, qqqminus !01apr15

 character (len=2) :: jz_c
 CHARACTER(*), PARAMETER :: fileplace = "/data/home/tew158/partdef/v21/calibration/calib22mpi/dataf/"
 do jz= 1,nz

 !zpluseps=zj(jz)-4.0_prec*sdeps
 !zminuseps=zj(jz)+1.5_prec*sdeps
  jy=locate_in_y(zj(jz))
!10jul15  jyplus=min(ny,locate_in_y(zj(jz)+uppereps)) !ny-4 !locate_in_y(zj(jz))+4
!10jul15  jyminus=max(1,locate_in_y(zj(jz)+lowereps)) !4 !1 !locate_in_y(zj(jz))-4
  jyplus=min(ny,locate_in_y(zj(jz)+3.0_prec*sdeps)) !10jul15
  jyminus=max(1,locate_in_y(zj(jz)-3.0_prec*sdeps)) !10jul15



 !jy=locate_in_y(zj(jz))
 !if(abs(yj(jy)-zj(jz)).gt.abs(yj(jy+1)-zj(jz))) jy=jy+1

     if(jz.lt.10) write(jz_c,'(i1)') jz !01apr14
     if(jz.ge.10) write(jz_c,'(i2)') jz

    open(297, file=fileplace//'d2Apr_z'//trim(jz_c)//'.dat')
    !open(297, file='d2Apr_z'//trim(jz_c)//'.dat')
    write(297,'(a14, f14.7, a14, i3)') 'z= ', zj(jz), 'jy= ', jy
    write(297,'(a14,a14,a14,a14,a14,a14,a14,a14,a14,a14,a14,a14,a14,a14,a14,a14)') &
        &   'A ',  'Apr ',  'def', 'b ','qq ', 'v ', &
        &   'Apr- ', 'def-', 'b- ', 'qq- ', 'v- ', &
        &   'Apr+ ', 'def+', 'b+ ', 'qq+ ', 'v+ '  !01apr15
    do ja=1, nA

!!*         !   ddum=lip(yj,DD_c(:,ja,jz),zj(jz))*Aj(ja)
!!*            if
!!*            bdum=lip(yj,BD_c(:,ja,jz),zj(jz))

    call splie2(Bj(1:nB),Dj,qq(1:nB,:,ja,jz),q2d) !01dec15

   if (D01(jy,ja,jz).eq.0) then
    def= zero
    apr=delta*Aj(ja)+BND_c(jy,ja,jz)
    v=vND(jy,ja,jz)
    b=BND_c(jy,ja,jz)
!    if(b.gt.zero+small) &
    qqq= splin2(Bj(1:nB),Dj,qq(1:nB,:,ja,jz),q2d,b,zero) !01dec15
    !b=b*qqq
   else if(D01(jy,ja,jz).eq.1) then
    def=DD_c(jy,ja,jz) !16jun17 *Aj(ja)
    apr=delta*Aj(ja)+BD_c(jy,ja,jz)+Rbar_Aver*(one-delta)*def*aj(ja) !16jun17
    v=vD(jy,ja,jz)
    b=BD_c(jy,ja,jz)
!    if(b.gt.zero+small) &
    qqq= splin2(Bj(1:nB),Dj,qq(1:nB,:,ja,jz),q2d,b,DD_c(jy,ja,jz))
    !b=b*qqq
   end if

!!*   if (D01(jyplus,ja,jz).eq.0) then
!!*    defplus= zero
!!*    aprplus=delta*Aj(ja)+BND_c(jyplus,ja,jz)
!!*    vplus=vND(jyplus,ja,jz)
!!*    bplus=BND_c(jy,ja,jz)
!!*   else if(D01(jyplus,ja,jz).eq.1) then
!!*    defplus=DD_c(jyplus,ja,jz)*aj(ja)
!!*    aprplus=delta*Aj(ja)+BD_c(jyplus,ja,jz)+Rbar_aver*(one-delta)*defplus
!!*    vplus=vD(jyplus,ja,jz)
!!*    bplus=BD_c(jy,ja,jz)
!!*   end if

   if (D01(jyminus,ja,jz).eq.0) then
    defminus= zero
    aprminus=delta*Aj(ja)+BND_c(jyminus,ja,jz)
    vminus=vND(jyminus,ja,jz)
    bminus=BND_c(jyminus,ja,jz)
    qqqminus= splin2(Bj(1:nB),Dj,qq(1:nB,:,ja,jz),q2d,bminus,zero) !01dec15
    !bminus=bminus*qqqminus !01apr15
   else if(D01(jyminus,ja,jz).eq.1) then
    defminus=DD_c(jyminus,ja,jz) !16jun17 *aj(ja)
    aprminus=delta*Aj(ja)+BD_c(jyminus,ja,jz)+Rbar_aver*(one-delta)*defminus*aj(ja) !16jun17
    vminus=vD(jyminus,ja,jz)
    bminus=BD_c(jyminus,ja,jz)
    qqqminus= splin2(Bj(1:nB),Dj,qq(1:nB,:,ja,jz),q2d,bminus,DD_c(jyminus,ja,jz)) !01dec15
    !bminus=bminus*qqqminus !01apr15
   end if

!01apr15
   if (D01(jyplus,ja,jz).eq.0) then
    defplus= zero
    aprplus=delta*Aj(ja)+BND_c(jyplus,ja,jz)
    vplus=vND(jyplus,ja,jz)
    bplus=BND_c(jyplus,ja,jz)
    qqqplus= splin2(Bj(1:nB),Dj,qq(1:nB,:,ja,jz),q2d,bplus,zero) !01dec15
    !bminus=bminus*qqqminus !01apr15
   else if(D01(jyplus,ja,jz).eq.1) then
    defplus=DD_c(jyplus,ja,jz)  !16jun17 *aj(ja)
    aprplus=delta*Aj(ja)+BD_c(jyplus,ja,jz)+Rbar_aver*(one-delta)*defplus*aj(ja) !16jun17
    vplus=vD(jyplus,ja,jz)
    bplus=BD_c(jyplus,ja,jz)
    qqqplus= splin2(Bj(1:nB),Dj,qq(1:nB,:,ja,jz),q2d,bplus,DD_c(jyplus,ja,jz)) !01dec15
    !bminus=bminus*qqqminus !01apr15
   end if

   write(297,'(f14.6,f14.6,f14.6,f14.6,f14.6,f14.6,f14.6,f14.6,f14.6,f14.6,f14.6 &
    & f14.6,f14.6,f14.6,f14.6,f14.6)')  &
    &   Aj(ja)/zaver_glob, apr/zaver_glob, def, b/zaver_glob, qqq, v, &   !16jun17
    &   aprminus/zaver_glob, defminus, bminus/zaver_glob, qqqminus, vminus, &
    &    aprplus/zaver_glob, defplus, bplus/zaver_glob, qqqplus, vplus        !01apr15
!   write(297,*) qqq, qqqminus, b, bminus

    end do
    close(297)
 end do

!!* contains
!!* function def(ydum)
!!*    jylow=count(yj.le.ydum)
!!*    jyup=min(jalow+1,nA)
!!*   if(D01(jy,jalow,jz).eq.1) then   !default
!!*    ddum= lip(Aj,DD_c(jy,:,jz),adum)*adum
!!*   else if (D01(jy,jaup,jz).eq.0) then       !no-default
!!*    ddum= zero
!!*   else
!!*    vtemp_ND=lip(Aj,vND(jy,:,jz),adum)
!!*    vtemp_D =lip(Aj, vD(jy,:,jz),adum)
!!*    if ( vtemp_ND.ge.vtemp_D) then
!!*     ddum= zero
!!*    else
!!*     ddum= lip(Aj,DD_c(jy,:,jz),adum)*adum
!!*    end if
!!*   end if
!!*   write(297,'(f14.4,f14.4)') adum, ddum
!!*   adum=adum+.0005


 end subroutine graph2d_eps_Apr

!03mar16
 subroutine graph2d_y_Apr
 use interp
 implicit none
 real(prec) :: ypr_exp
 integer :: jy, jyplus, jyminus
 real(prec) :: def,  &
    &   apr,  &
    &   v,  &
    &   b,  &
    &   qqq

 character (len=2) :: jz_c

 ja=ja_valD
 do jz= 1,nz

     if(jz.lt.10) write(jz_c,'(i1)') jz !01apr14
     if(jz.ge.10) write(jz_c,'(i2)') jz

    open(297, file='d2_y_Apr_z'//trim(jz_c)//'.dat')
    write(297,'(a4, i3, a4, f6.4, a4, i3, a4, f6.4)') 'jz ', jz, 'z ', zj(jz), 'ja ', ja, 'a ', aj(ja)
    write(297,'(a14,a14,a14,a14,a14,a14,a14,a14,a14,a14)') &
        &   'jy ', 'y ', 'Apr ',  'def ', 'b ','qq ', 'v ','E ypr ', 'QxB ', 'DxA '
    do jy=1, ny

    call splie2(Bj(1:nB),Dj,qq(1:nB,:,ja,jz),q2d) !01dec15

   if (D01(jy,ja,jz).eq.0) then
    def= zero
    apr=delta*Aj(ja)+BND_c(jy,ja,jz)
    v=vND(jy,ja,jz)
    b=BND_c(jy,ja,jz)
    qqq= splin2(Bj(1:nB),Dj,qq(1:nB,:,ja,jz),q2d,b,zero) !01dec15
    !b=b*qqq
   else if(D01(jy,ja,jz).eq.1) then
    def=DD_c(jy,ja,jz) !*Aj(ja)
    apr=delta*Aj(ja)+BD_c(jy,ja,jz)+Rbar_aver*(one-delta)*def*aj(ja)
    v=vD(jy,ja,jz)
    b=BD_c(jy,ja,jz)
    qqq= splin2(Bj(1:nB),Dj,qq(1:nB,:,ja,jz),q2d,b,DD_c(jy,ja,jz))
    !b=b*qqq
   end if

   ypr_exp=zj(jz)*psi(def,jz,apr)

   write(297,'(i14,f14.6,f14.6,f14.6,f14.6,f14.6,f14.6,f14.6,f14.6,f14.6)')  &
    &   jy,  yj(jy),  apr, def, b, qqq, v, ypr_exp, qqq*b, def*aj(ja)
    end do
    close(297)
 end do

 end subroutine graph2d_y_Apr

! **********************************************************
! welfare
! **********************************************************
!11sep21
subroutine write_welf

 implicit none
 real(prec) :: def, yy
 integer :: jjz, jja
 integer, dimension(:), allocatable :: iy_map

 allocate(iy_map(nz))

!   real(prec), dimension(:), allocatable ::  vD(:,:,:), v(:,:,:)
!   allocate ( vD(1:ny,1:nA,1:nz), v(1:ny,1:nA,1:nz) )
!   allocate ( vND(1:ny,1:nA,1:nz),vNDold(1:ny,1:nA,1:nz) ) !03feb15
!   nAzero
!   zaver_glob
!   a_aver2
!   yypr=zj(jjzpr)*psi(ddd,jjzpr,aapr)

    ! For default 0.50
    def=0.50_prec
    do jjz=1, nz
     yy=zj(jjz)*psi(def,jjz,a_aver2)
     iy_map(jjz)=count(yj(:).le.yy)
     if(abs(yj(iy_map(jjz))-yy).gt.abs(yj(min(iy_map(jjz)+1,ny)-yy) ) ) &
        iy_map(jjz)=min(iy_map(jjz)+1,ny)
    end do
    open(48, file='welf_def050.dat')
!03jun22    write(48,'(2a5,2a14,a14)') 'jja', 'jjz', 'a', 'z', 'val'
!03jun22    do jjz=1, nz
!03jun22     do jja=1, nA
!03jun22      !vv_arrears50pc(jja,jjz)=max(vD(iy_map(jjz),jja,jjz),vND(iy_map(jjz),jja,jjz))
!03jun22      write(48,'(2i5,2f14.6,f14.8)') jja, jjz, Aj(jja), zj(jjz), max(vD(iy_map(jjz),jja,jjz),vND(iy_map(jjz),jja,jjz))
!03jun22     end do
!03jun22    end do
!03jun22
    write(48,'(2a5,2a14,a14,a14)') 'jja', 'jjz', 'a', 'z', 'val', 'H'
    do jjz=1, nz
     do jja=1, nA
      write(48,'(2i5,2f14.6,2f14.8)') jja, jjz, Aj(jja), zj(jjz), max(vD(iy_map(jjz),jja,jjz),vND(iy_map(jjz),jja,jjz)), H(iy_map(jjz),jja,jjz)
     end do
    end do
    close(48)

    ! For default 1.00
    def=1.00_prec
    do jjz=1, nz
     yy=zj(jjz)*psi(def,jjz,a_aver2)
     iy_map(jjz)=count(yj(:).le.yy)
     if(abs(yj(iy_map(jjz))-yy).gt.abs(yj(min(iy_map(jjz)+1,ny)-yy) ) ) &
        iy_map(jjz)=min(iy_map(jjz)+1,ny)
    end do
    open(48, file='welf_def100.dat')
!03jun22    write(48,'(2a5,2a14,a14)') 'jja', 'jjz', 'a', 'z', 'val'
!03jun22    do jjz=1, nz
!03jun22     do jja=1, nA
!03jun22      !vv_arrears50pc(jja,jjz)=max(vD(iy_map(jjz),jja,jjz),vND(iy_map(jjz),jja,jjz))
!03jun22      write(48,'(2i5,2f14.6,f14.8)') jja, jjz, Aj(jja), zj(jjz), max(vD(iy_map(jjz),jja,jjz),vND(iy_map(jjz),jja,jjz))
!03jun22     end do
!03jun22    end do
!03jun22
    write(48,'(2a5,2a14,a14,a14)') 'jja', 'jjz', 'a', 'z', 'val', 'H'
    do jjz=1, nz
     do jja=1, nA
      write(48,'(2i5,2f14.6,2f14.8)') jja, jjz, Aj(jja), zj(jjz), max(vD(iy_map(jjz),jja,jjz),vND(iy_map(jjz),jja,jjz)), H(iy_map(jjz),jja,jjz)
     end do
    end do
    close(48)

    ! For default 0.00
    def=0.00_prec
    do jjz=1, nz
     yy=zj(jjz)*psi(def,jjz,a_aver2)
     iy_map(jjz)=count(yj(:).le.yy)
     if(abs(yj(iy_map(jjz))-yy).gt.abs(yj(min(iy_map(jjz)+1,ny)-yy) ) ) &
        iy_map(jjz)=min(iy_map(jjz)+1,ny)
    end do
    open(48, file='welf_def000.dat')
!03jun22    write(48,'(2a5,2a14,a14)') 'jja', 'jjz', 'a', 'z', 'val'
!03jun22    do jjz=1, nz
!03jun22     do jja=1, nA
!03jun22      !vv_arrears50pc(jja,jjz)=max(vD(iy_map(jjz),jja,jjz),vND(iy_map(jjz),jja,jjz))
!03jun22      write(48,'(2i5,2f14.6,f14.8)') jja, jjz, Aj(jja), zj(jjz), max(vD(iy_map(jjz),jja,jjz),vND(iy_map(jjz),jja,jjz))
!03jun22     end do
!03jun22    end do
!03jun22
    write(48,'(2a5,2a14,a14,a14)') 'jja', 'jjz', 'a', 'z', 'val', 'H'
    do jjz=1, nz
     do jja=1, nA
      write(48,'(2i5,2f14.6,2f14.8)') jja, jjz, Aj(jja), zj(jjz), max(vD(iy_map(jjz),jja,jjz),vND(iy_map(jjz),jja,jjz)), H(iy_map(jjz),jja,jjz)
     end do
    end do
    close(48)

!25oct21
    open(48, file='values.dat')
    write(48,'(2a5,2a14,a14)') 'jy', 'ja', 'jz', 'val'
    do jy=1, ny
     do ja=1, nA
      do jz=1, nz
      write(48,'(3i5,f15.10)') jy, ja, jz, max(vD(jy,ja,jz),vND(jy,ja,jz))
      end do
     end do
    end do
    close(48)


    deallocate(iy_map)

end subroutine write_welf


! **********************************************************
! [13.] IRF
!*******************************************************
subroutine simul_IRF

 use interp

 implicit none

 integer :: time
 real(prec) :: parsum, qqqtil
 real(prec) :: x_z
 integer :: japr, jypr, jzpr, jz_aver

 integer :: ntime

 real(prec), dimension(:), allocatable :: z(:),a(:),y(:),b(:),d(:),c(:),spread(:),tb(:),q(:)
 real(prec), dimension(:), allocatable ::  partdef(:)
 integer, dimension(:), allocatable ::  jzpath(:)
 real(prec), dimension(:), allocatable :: epspath(:)

 real(prec) :: atarget, ytarget

 integer :: jaup, jalow, jyup, jylow
 real(prec) :: vtemp_ND, vtemp_D

 real(prec), dimension(:), allocatable :: RRbar(:) !16oct14

 real(prec) :: eps

    ntime=10

    allocate (z(ntime),a(ntime),y(ntime),b(ntime),d(ntime),c(ntime),q(ntime),tb(ntime),spread(ntime))
    allocate(RRbar(ntime))
    allocate (partdef(ntime))
    allocate (jzpath(ntime),epspath(ntime))

  open (42, file='simulpaths_IRF0.dat')
  open (43, file='simulpaths_IRF1.dat')
  open (44, file='simulpaths_IRF2.dat')

    ! .. To be chosen by user in simul_IRF ..
    ! Have to choose:  jz_aver
    ! Maybe also change from atarget=a_aver2
    ! For z shock: Have to specify jzpath(1), jzpath(2), ...
    ! For eps shock: Have to specify epspath(1)
    ! Also the write choices into write(42,) depending on shock


    ! .. Persistent productivity z ..
    jz_aver=4
    jzpath=jz_aver
    !   .. if shock to z ..
    !jzpath(2)=jz_aver-1
    ! .. iid component  eps ..
    epspath=zero
    !   .. if shock to eps ..
    !epspath(2)=-0.03_prec*zj(jzpath(2))


    iR=1
    RRbar= Rbar(iR)


! Initial States

    jz=jzpath(1)
    ytarget=zj(jz)
    atarget=.029_prec !quarterly average a_aver2


 noconv=0
 !-----------------------------------------------------------
 ! BENCHMARK
 !-----------------------------------------------------------
    write(42,*) 'Baseline:', 'jz ', jz_aver, 'a ', atarget
    write(42,*) 'No Shocks benchmark '
    write(42,*) 'time, y,  z, a, b, d, R, c, spr ' !16oct14


 do time=1, ntime

    ! [0] .. States ..
    z(time)=zj(jz)
    a(time)=atarget
    y(time)=ytarget



    ! [3] .. endogenous decision and prices..

    ! .. locate box containing (yypr, aapr)
    jylow=count(yj.le.y(time))
    jyup=min(jylow+1,ny)
    jalow=count(Aj.le.a(time))
    jaup=min(jalow+1,nA)
   if(D01(jyup,jalow,jz).eq.1) then   !default
    b(time)= blip(yj,Aj,BD_c(:,:,jz),y(time),a(time))
    d(time)= blip(yj,Aj,DD_c(:,:,jz),y(time),a(time))*a(time)
   else if (D01(jylow,jaup,jz).eq.0) then       !no-default
    b(time)= blip(yj,Aj,BND_c(:,:,jz),y(time),a(time))
    d(time)=zero
   else
    vtemp_ND=blip(yj,Aj,vND(:,:,jz),y(time),a(time))
    vtemp_D =blip(yj,Aj, vD(:,:,jz),y(time),a(time))
    if ( vtemp_ND.ge.vtemp_D) then
     b(time)= blip(yj,Aj,BND_c(:,:,jz),y(time),a(time))
     d(time)= zero
    else
     b(time)= blip(yj,Aj,BD_c(:,:,jz),y(time),a(time))
     d(time)= blip(yj,Aj,DD_c(:,:,jz),y(time),a(time))*a(time)
    end if
   end if


    if(a(time).gt.zero) then
        partdef(time)=d(time)/a(time)!15oct14
    else
        partdef(time)=zero
    end if

    if(b(time).ge.Bj(nBzero)) then !04aug14 !01dec15
        qqqtil=lininterp3(Bj(1:nB),Dj(1:nD),Aj(1:nA), &  !10jul14
                &   qq(1:nB,1:nD,1:nA,jz), &
!06mar16                &   b(time),d(time),a(time)) !10jul14
                &   b(time),partdef(time),a(time)) !06mar16
    else
      if(nobuybacks.eq.1) then !30nov15
        qqqtil=q0/(one-q0*delta) !10apr14
      else if(nobuybacks.eq.0) then !01dec15
        qqqtil=lininterp3(Bj(1:nB),Dj(1:nD),Aj(1:nA), &
                &   qq(1:nB,1:nD,1:nA,jz), &
!06mar16                &   b(time),d(time),a(time))
                &   b(time),partdef(time),a(time)) !06mar16
      end if
    end if



    q(time)=qqqtil !07mar14
    spread(time)= (((one/qqqtil)+delta)**modelfreq)-((one/q0)**modelfreq)
    c(time)=y(time)-(a(time)-d(time)) &
        & +qqqtil*b(time)
    tb(time)=y(time)-c(time) !09apr13


    ! .. write stuff ..
    write(42,'( &
                    & i6,f10.6,f10.6,f10.6, &
                    & f10.6,f10.6, &
                    & f10.6, &
                    & f10.6,f10.6)') &
        & time, y(time),  z(time), a(time),  &
        & b(time), d(time), &
        & RRbar(time),  &
        & c(time), spread(time)


    ![4] .. Next period states ..
    jz=jzpath(time+1)

    eps=epspath(time+1)

    atarget=max(Aj(1),b(time)+(one-delta)*RRbar(time)*d(time)+max(delta*a(time),zero))
    ytarget=min((zj(jz)+eps)*psi(partdef(time),jz,atarget),yj(ny)) !06mar16

 end do !time
 close(42)

 !-----------------------------------------------------------
 ! SHOCK TO z
 !-----------------------------------------------------------
! Initial States
    jzpath=jz_aver
    epspath=zero

    jz=jzpath(1)
    ytarget=zj(jz)
    atarget=.029_prec !quarterly average a_aver2

    !   .. if shock to z ..
    jzpath(2)=jz_aver-1

    write(43,*) 'Baseline:', 'jz ', jz_aver, 'a ', atarget
    write(43,*) 'Shock: ', 'in period 2',  'z ', jzpath(2)
    write(43,*) 'time, y,  z, a, b, d, R, c, spr ' !16oct14

 do time=1, ntime

    ! [0] .. States ..
    z(time)=zj(jz)
    a(time)=atarget
    y(time)=ytarget



    ! [3] .. endogenous decision and prices..

    ! .. locate box containing (yypr, aapr)
    jylow=count(yj.le.y(time))
    jyup=min(jylow+1,ny)
    jalow=count(Aj.le.a(time))
    jaup=min(jalow+1,nA)
   if(D01(jyup,jalow,jz).eq.1) then   !default
    b(time)= blip(yj,Aj,BD_c(:,:,jz),y(time),a(time))
    d(time)= blip(yj,Aj,DD_c(:,:,jz),y(time),a(time))*a(time)
   else if (D01(jylow,jaup,jz).eq.0) then       !no-default
    b(time)= blip(yj,Aj,BND_c(:,:,jz),y(time),a(time))
    d(time)=zero
   else
    vtemp_ND=blip(yj,Aj,vND(:,:,jz),y(time),a(time))
    vtemp_D =blip(yj,Aj, vD(:,:,jz),y(time),a(time))
    if ( vtemp_ND.ge.vtemp_D) then
     b(time)= blip(yj,Aj,BND_c(:,:,jz),y(time),a(time))
     d(time)= zero
    else
     b(time)= blip(yj,Aj,BD_c(:,:,jz),y(time),a(time))
     d(time)= blip(yj,Aj,DD_c(:,:,jz),y(time),a(time))*a(time)
    end if
   end if


    if(a(time).gt.zero) then
        partdef(time)=d(time)/a(time)!15oct14
    else
        partdef(time)=zero
    end if

    if(b(time).ge.Bj(nBzero)) then !04aug14 !01dec15
        qqqtil=lininterp3(Bj(1:nB),Dj(1:nD),Aj(1:nA), &  !10jul14
                &   qq(1:nB,1:nD,1:nA,jz), &
!06mar16                &   b(time),d(time),a(time)) !10jul14
                &   b(time),partdef(time),a(time)) !06mar16
    else
      if(nobuybacks.eq.1) then !30nov15
        qqqtil=q0/(one-q0*delta) !10apr14
      else if(nobuybacks.eq.0) then !01dec15
        qqqtil=lininterp3(Bj(1:nB),Dj(1:nD),Aj(1:nA), &
                &   qq(1:nB,1:nD,1:nA,jz), &
!06mar16                &   b(time),d(time),a(time))
                &   b(time),partdef(time),a(time)) !06mar16
      end if
    end if



    q(time)=qqqtil !07mar14
    spread(time)= (((one/qqqtil)+delta)**modelfreq)-((one/q0)**modelfreq)
    c(time)=y(time)-(a(time)-d(time)) &
        & +qqqtil*b(time)
    tb(time)=y(time)-c(time) !09apr13


    ! .. write stuff ..
    write(43,'( &
                    & i6,f10.6,f10.6,f10.6, &
                    & f10.6,f10.6, &
                    & f10.6, &
                    & f10.6,f10.6)') &
        & time, y(time),  z(time), a(time),  &
        & b(time), d(time), &
        & RRbar(time),  &
        & c(time), spread(time)


    ![4] .. Next period states ..
    jz=jzpath(time+1)

    eps=epspath(time+1)

    atarget=max(Aj(1),b(time)+(one-delta)*RRbar(time)*d(time)+max(delta*a(time),zero))
    ytarget=min((zj(jz)+eps)*psi(partdef(time),jz,atarget),yj(ny)) !06mar16

 end do !time
 close(43)

 !-----------------------------------------------------------
 ! SHOCK TO eps
 !-----------------------------------------------------------
! Initial States
    jzpath=jz_aver
    epspath=zero

    jz=jzpath(1)
    ytarget=zj(jz)
    atarget=.029_prec !quarterly average a_aver2

    !   .. if shock to eps ..
    epspath(2)=-0.03_prec*zj(jzpath(2))

    write(44,*) 'Baseline:', 'jz ', jz_aver, 'a ', atarget
    write(44,*) 'Shock: ', 'in period 2',  'eps ', epspath(2)
    write(44,*) 'time, y,  z, a, b, d, R, c, spr ' !16oct14

 do time=1, ntime

    ! [0] .. States ..
    z(time)=zj(jz)
    a(time)=atarget
    y(time)=ytarget



    ! [3] .. endogenous decision and prices..

    ! .. locate box containing (yypr, aapr)
    jylow=count(yj.le.y(time))
    jyup=min(jylow+1,ny)
    jalow=count(Aj.le.a(time))
    jaup=min(jalow+1,nA)
   if(D01(jyup,jalow,jz).eq.1) then   !default
    b(time)= blip(yj,Aj,BD_c(:,:,jz),y(time),a(time))
    d(time)= blip(yj,Aj,DD_c(:,:,jz),y(time),a(time))*a(time)
   else if (D01(jylow,jaup,jz).eq.0) then       !no-default
    b(time)= blip(yj,Aj,BND_c(:,:,jz),y(time),a(time))
    d(time)=zero
   else
    vtemp_ND=blip(yj,Aj,vND(:,:,jz),y(time),a(time))
    vtemp_D =blip(yj,Aj, vD(:,:,jz),y(time),a(time))
    if ( vtemp_ND.ge.vtemp_D) then
     b(time)= blip(yj,Aj,BND_c(:,:,jz),y(time),a(time))
     d(time)= zero
    else
     b(time)= blip(yj,Aj,BD_c(:,:,jz),y(time),a(time))
     d(time)= blip(yj,Aj,DD_c(:,:,jz),y(time),a(time))*a(time)
    end if
   end if


    if(a(time).gt.zero) then
        partdef(time)=d(time)/a(time)!15oct14
    else
        partdef(time)=zero
    end if

    if(b(time).ge.Bj(nBzero)) then !04aug14 !01dec15
        qqqtil=lininterp3(Bj(1:nB),Dj(1:nD),Aj(1:nA), &  !10jul14
                &   qq(1:nB,1:nD,1:nA,jz), &
!06mar16                &   b(time),d(time),a(time)) !10jul14
                &   b(time),partdef(time),a(time)) !06mar16
    else
      if(nobuybacks.eq.1) then !30nov15
        qqqtil=q0/(one-q0*delta) !10apr14
      else if(nobuybacks.eq.0) then !01dec15
        qqqtil=lininterp3(Bj(1:nB),Dj(1:nD),Aj(1:nA), &
                &   qq(1:nB,1:nD,1:nA,jz), &
!06mar16                &   b(time),d(time),a(time))
                &   b(time),partdef(time),a(time)) !06mar16
      end if
    end if



    q(time)=qqqtil !07mar14
    spread(time)= (((one/qqqtil)+delta)**modelfreq)-((one/q0)**modelfreq)
    c(time)=y(time)-(a(time)-d(time)) &
        & +qqqtil*b(time)
    tb(time)=y(time)-c(time) !09apr13


    ! .. write stuff ..
    write(44,'( &
                    & i6,f10.6,f10.6,f10.6, &
                    & f10.6,f10.6, &
                    & f10.6, &
                    & f10.6,f10.6)') &
        & time, y(time),  z(time), a(time),  &
        & b(time), d(time), &
        & RRbar(time),  &
        & c(time), spread(time)


    ![4] .. Next period states ..
    jz=jzpath(time+1)

    eps=epspath(time+1)

    atarget=max(Aj(1),b(time)+(one-delta)*RRbar(time)*d(time)+max(delta*a(time),zero))
    ytarget=min((zj(jz)+eps)*psi(partdef(time),jz,atarget),yj(ny)) !06mar16

 end do !time
 close(44)


end subroutine simul_IRF

!********************************************************************
!12feb17
 subroutine stochsimul_IRF(ntime,npaths)

 use interp

 implicit none

 integer :: ntime, npaths
 integer :: time, pathindex
 integer :: count_seed
 real(prec) :: parsum, qqqtil
 real(prec) :: x_z
 integer :: japr, jypr, jzpr

 integer, parameter:: nshocks=2 !10jul14 nshocks=4 !06mar14 nshocks=2 !09jan14
 real(prec), dimension(:), allocatable:: ran_out(:)
 integer, dimension(:), allocatable:: seed(:)

 real(prec), dimension(:), allocatable :: z(:),a(:),y(:),b(:),d(:),c(:),spread(:),tb(:),q(:)
 real(prec), dimension(:), allocatable ::  partdef(:) !15oct14



 real(prec) :: x_rr !09jan14
 real(prec) :: x_a, x_y, prob_a_l, prob_y_l, atarget, ytarget !06mar14
 real(prec), dimension(:), allocatable :: trr(:), tAr(:)   !09jan14
 integer, dimension(:), allocatable ::  tR(:)   !09jan14

 integer :: jaup, jalow, jyup, jylow !07feb15
 real(prec) :: vtemp_ND, vtemp_D

 real(prec) :: x_R !16oct14
 real(prec), dimension(:), allocatable :: RRbar(:) !16oct14


 real(prec), dimension(:), allocatable :: z_aver(:),a_aver(:),y_aver(:),b_aver(:),d_aver(:),c_aver(:),spread_aver(:)
 real(prec), dimension(:), allocatable :: RRbar_aver(:)



 integer :: seed_eps !08feb15
 real(prec) :: x_eps
 real(prec) :: RRbartarget !10jan16

    real(prec) :: pc_z, pc_D !20apr17

 CHARACTER(*), PARAMETER :: fileplace = "/data/home/tew158/partdef/v21/calibration/calib22mpi/IRF/"
!    integer, dimension(:), allocatable :: countpaths(:) !20jun17

    allocate (ran_out(nshocks))
    allocate (seed(nshocks))
    allocate (z(ntime),a(ntime),y(ntime),b(ntime),d(ntime),c(ntime),q(ntime),tb(ntime),spread(ntime))
    allocate(RRbar(ntime)) !16oct14
    allocate (trr(ntime), tAr(ntime), tR(ntime) )   !09jan14
    allocate (partdef(ntime))!15oct14

    allocate (z_aver(ntime),a_aver(ntime),y_aver(ntime),b_aver(ntime),d_aver(ntime),c_aver(ntime),spread_aver(ntime))
    allocate(RRbar_aver(ntime))

!    allocate(countpaths(ntime)) !20jun17

    open(297, file=fileplace//'simulIRFparam.dat')
    write(297,'(a14,a14,a14,a14)') 'delta', 'q0', 'freq', 'zaver_glob'
    write(297,'(f14.6,f14.6,f14.6,f14.6)') delta, q0, modelfreq, zaver_glob
    close(297)

    if(doIRF.eq.2)  open (42, file='stochsimulIRF_y.dat')
    if(doIRF.eq.3)  open (42, file='stochsimulIRF_z.dat')
    !if(doIRF.eq.4)  open (42, file='stochsimulIRF_zandy.dat')
    if(doIRF.eq.4)  then
     if(dropjz_IRF.eq.1) then
        open (42, file=fileplace//'stochsimulIRF_zandy.dat')
     else if(dropjz_IRF.eq.2) then
        open (42, file=fileplace//'stochsimulIRF_zandy_2j.dat')
     else
        open (42, file=fileplace//'stochsimulIRF_zandy.dat')
     end if
    end if
    if(doIRF.eq.5)  open (42, file='stochsimulIRF_yandA.dat')
    if(doIRF.eq.6)  open (42, file='stochsimulIRF_A.dat')
    write(42,*) ' --------------------'
    write(42,*) ' PATHS '
    write(42,*) ' --------------------'
    write(42,*) 'time, y,  z, a, b, d, R, c, spr '

        y_aver(:)=zero
        z_aver(:)=zero
        a_aver(:)=zero
        b_aver(:)=zero
        d_aver(:)=zero
        RRbar_aver(:)=zero
        c_aver(:)=zero
        spread_aver(:)=zero

! countpaths(:)=0 !20jun17
 do pathindex=1, npaths
 write(defout,*) ' path number ', pathindex

! Initial States
    jz=int(nz/2)
    ytarget=zj(jz)
    atarget=a_aver2/modelfreq !zero

!    write(*,*) 'aver2=', a_aver2
!    pause

    CALL SYSTEM_CLOCK( count_seed )

    seed(1) = count_seed
    seed(2) = count_seed+1

    CALL random_seed(put=seed(1:nshocks))

    CALL SYSTEM_CLOCK( count_seed )
    seed_eps = count_seed


 do time=1, ntime

    ! [0] .. States ..
    z(time)=zj(jz)
    a(time)=atarget
    y(time)=ytarget

    ! [1] .. Exogenous stochastic shocks ..
    CALL random_number(ran_out(1:nshocks))

    ! .. z next ..
    x_z=ran_out(1)

    ! .. x_eps next ..
    if(noise_epsV.eq.1) then
    call truncated_normal_ab_sample(avereps, sdeps, lowereps, uppereps, &
        & seed_eps, x_eps ) !08feb15
    else
        x_eps=zero
    end if

    ! .. x_R now ..
    x_R=ran_out(2) !16oct14


    ! [2] .. Current Rbar ..
    if(x_R.eq.one) then     !16oct14
        iR=nR
    else if(x_R.eq.zero) then
        iR=1
    else
        parsum=zero
        do iR=1, nR
            if((x_R.ge.parsum).and.(x_R.lt.parsum+piR(iR)))  exit
            parsum=parsum+piR(iR)
        end do
    end if

    RRbar(time)= Rbar(iR) !10jan16

    ! [3] .. endogenous decision and prices..

    ! .. locate box containing (yypr, aapr)
    jylow=count(yj.le.y(time))
    jyup=min(jylow+1,ny)
    jalow=count(Aj.le.a(time))
    jaup=min(jalow+1,nA)
   if(D01(jyup,jalow,jz).eq.1) then   !default
    b(time)= blip(yj,Aj,BD_c(:,:,jz),y(time),a(time))
    d(time)= blip(yj,Aj,DD_c(:,:,jz),y(time),a(time))*a(time)
   else if (D01(jylow,jaup,jz).eq.0) then       !no-default
    b(time)= blip(yj,Aj,BND_c(:,:,jz),y(time),a(time))
    d(time)=zero
   else
    vtemp_ND=blip(yj,Aj,vND(:,:,jz),y(time),a(time))
    vtemp_D =blip(yj,Aj, vD(:,:,jz),y(time),a(time))
    if ( vtemp_ND.ge.vtemp_D) then
     b(time)= blip(yj,Aj,BND_c(:,:,jz),y(time),a(time))
     d(time)= zero
    else
     b(time)= blip(yj,Aj,BD_c(:,:,jz),y(time),a(time))
     d(time)= blip(yj,Aj,DD_c(:,:,jz),y(time),a(time))*a(time)
    end if
   end if


    if(a(time).gt.zero) then
        partdef(time)=d(time)/a(time)!15oct14
    else
        partdef(time)=zero
    end if

    if(b(time).ge.Bj(nBzero)) then !04aug14 !01dec15
        qqqtil=lininterp3(Bj(1:nB),Dj(1:nD),Aj(1:nA), &  !10jul14
                &   qq(1:nB,1:nD,1:nA,jz), &
                &   b(time),partdef(time),a(time)) !06mar16

    else
      if(nobuybacks.eq.1) then !30nov15
        qqqtil=q0/(one-q0*delta) !10apr14
      else if(nobuybacks.eq.0) then !01dec15
        qqqtil=lininterp3(Bj(1:nB),Dj(1:nD),Aj(1:nA), &
                &   qq(1:nB,1:nD,1:nA,jz), &
                &   b(time),partdef(time),a(time))
      end if
    end if


    q(time)=qqqtil !07mar14
    spread(time)= (((one/qqqtil)+delta)**modelfreq)-((one/q0)**modelfreq)
    c(time)=y(time)-(a(time)-d(time)) &
        & +qqqtil*b(time)
    tb(time)=y(time)-c(time) !09apr13

    tR(time)=0

!    if((a(time)).ge.(1.50_prec*0.0346_prec)) then !20jun17
!        countpaths(time)=countpaths(time)+1 !20jun17

        ! .. cumulative values over paths ..
        y_aver(time)=y_aver(time)+y(time)
        z_aver(time)=z_aver(time)+z(time)
        a_aver(time)=a_aver(time)+a(time)
        b_aver(time)=b_aver(time)+b(time)
        d_aver(time)=d_aver(time)+d(time)
        RRbar_aver(time)=RRbar_aver(time)+RRbar(time)
        c_aver(time)=c_aver(time)+c(time)
        spread_aver(time)=spread_aver(time)+spread(time)

!    end if

    ![4] .. Next period states ..
    if(x_z.eq.one) then
        jzpr=nz
    else if(x_z.eq.zero) then
        jzpr=1
    else
        parsum=zero
        do jzpr=1, nz
            if((x_z.ge.parsum).and.(x_z.lt.parsum+piz(jz,jzpr)))  exit
            parsum=parsum+piz(jz,jzpr)
        end do
    end if
    !Update
    jz=jzpr


    atarget=max(Aj(1),b(time)+(one-delta)*Rbar(iR)*d(time)+max(delta*a(time),zero)) !28jun15
    ytarget=min((zj(jzpr)+x_eps)*psi(partdef(time),jzpr,atarget),yj(ny)) !06mar16 !07jun15 !08feb15

    if( (time.eq.int(ntime/2)).and.(doIRF.eq.2) ) &
        & ytarget=max(ytarget*0.95_prec,yj(1)) !5% fall in output
        !& ytarget=max(ytarget*0.97_prec,yj(1)) !3% fall in output

    if( (time.eq.int(ntime/2)).and.(doIRF.eq.3) ) &
        & jz=max(jz-1,1) !one-bin fall in persistent output

!20apr17
    if( (time.eq.int(ntime/2)).and.(doIRF.eq.4) ) then
!        ! 1-index drop
!        pc_z=zj(max(jz-1,1))/zj(jz)
!        jz=max(jz-1,1) !one-bin fall in persistent output
!        ! 2-index drop      !20jun17
!        !pc_z=zj(max(jz-2,1))/zj(jz)
!        !jz=max(jz-2,1) !two-bin fall in persistent output
!        ! 1-index jump
!        !pc_z=zj(min(jz+1,nz))/zj(jz)
!        !jz=min(jz+1,nz) !one-bin fall in persistent output
        pc_z=zj(min(max(jz-dropjz_IRF,1),nz))/zj(jz)
        jz=max(jz-dropjz_IRF,1)
        ytarget=max(ytarget*pc_z,yj(1))
    end if

    if( (time.eq.int(ntime/2)).and.(doIRF.eq.5) ) then
        pc_D=1.00_prec
        ytarget=min((zj(jzpr)+x_eps)*psi(partdef(time)*(one+pc_D),jzpr,atarget),yj(ny))
        atarget=max(Aj(1),b(time)+(one-delta)*Rbar(iR)*d(time)*(one+pc_D)+max(delta*a(time),zero))
    end if

    if( (time.eq.int(ntime/2)).and.(doIRF.eq.6) ) &
        & atarget=min(atarget*1.05_prec,Aj(nA))





 end do !time


 end do !pathindex loop

!20jun17
        y_aver(:)=y_aver(:)/real(npaths)
        z_aver(:)=z_aver(:)/real(npaths)
        a_aver(:)=a_aver(:)/real(npaths)
        b_aver(:)=b_aver(:)/real(npaths)
        d_aver(:)=d_aver(:)/real(npaths)
        RRbar_aver(:)=RRbar_aver(:)/real(npaths)
        c_aver(:)=c_aver(:)/real(npaths)
        spread_aver(:)=spread_aver(:)/real(npaths)
!20jun17
!        y_aver(:)=y_aver(:)/real(max(1,countpaths(:)))
!        z_aver(:)=z_aver(:)/real(max(1,countpaths(:)))
!        a_aver(:)=a_aver(:)/real(max(1,countpaths(:)))
!        b_aver(:)=b_aver(:)/real(max(1,countpaths(:)))
!        d_aver(:)=d_aver(:)/real(max(1,countpaths(:)))
!        RRbar_aver(:)=RRbar_aver(:)/real(max(1,countpaths(:)))
!        c_aver(:)=c_aver(:)/real(max(1,countpaths(:)))
!        spread_aver(:)=spread_aver(:)/real(max(1,countpaths(:)))

    if((doIRF.eq.2).or.(doIRF.eq.3) &
        & .or.(doIRF.eq.4).or.(doIRF.eq.5).or.(doIRF.eq.6)) then
        do time=1, ntime
        write(42,'( &
                    & i6,f10.6,f10.6,f10.6, &
                    & f10.6,f10.6, &
                    & f10.6, &
                    & f10.6,f10.6)') &
            & time, y_aver(time),  z_aver(time), a_aver(time),  &
            & b_aver(time), d_aver(time), &
            & RRbar_aver(time),  &
            & c_aver(time), spread_aver(time)
        end do
    end if

! if(doIRF.eq.2) then
! do time=1, ntime
!     write(42,'( &
!                    & i6,f10.6,f10.6,f10.6, &
!                    & f10.6,f10.6, &
!                    & f10.6, &
!                    & f10.6,f10.6)') &
!        & time, y_aver(time),  z_aver(time), a_aver(time),  &
!        & b_aver(time), d_aver(time), &
!        & RRbar_aver(time),  &
!        & c_aver(time), spread_aver(time)
! end do
! end if
! if(doIRF.eq.3) then
! do time=1, ntime
!     write(42,'( &
!                    & i6,f10.6,f10.6,f10.6, &
!                    & f10.6,f10.6, &
!                    & f10.6, &
!                    & f10.6,f10.6)') &
!        & time, y_aver(time),  z_aver(time), a_aver(time),  &
!        & b_aver(time), d_aver(time), &
!        & RRbar_aver(time),  &
!        & c_aver(time), spread_aver(time)
! end do
! end if

 deallocate(z,a,y,b,d,c,q,tb)
 deallocate(z_aver,a_aver,y_aver,b_aver,d_aver,c_aver,spread_aver,RRbar_aver)

 close(42)


 end subroutine stochsimul_IRF

!*******************************************************
!20sep14
 subroutine simul_ARG_old
 use interp
 implicit none
 real(prec) :: z_aver
 integer :: time
 integer, parameter :: horizonARG=37
 real(prec), dimension(:), allocatable:: logdevy(:), yARG(:)
 real(prec), dimension(:), allocatable:: jzARG(:)

 real(prec) :: parsum, qqqtil
 integer :: japr, jypr, jzpr

 real(prec), dimension(:), allocatable :: z(:),a(:),y(:),b(:),d(:),c(:),spread(:),tb(:),q(:)

 real(prec) :: atarget, ytarget

    allocate (z(horizonARG),a(horizonARG),y(horizonARG),b(horizonARG), &
        & d(horizonARG),c(horizonARG),q(horizonARG),tb(horizonARG),spread(horizonARG))

 allocate(logdevy(horizonARG), yARG(horizonARG), jzARG(horizonARG) )


    z_aver=one !0.5_prec !sum(z(1:ntime))/ntime

    open (298, file='argy_70_06.txt', status='old')

    read(298,*)
    do time=1, horizonARG
        read (298, *) logdevy(time)
        yARG(time)=exp(logdevy(time))*z_aver
    end do

    close(298)

    do time=1, horizonARG
    jzARG(time)=count(zj.le.yARG(time))
    if(jzARG(time).lt.nz) then
        if(abs(zj(jzARG(time))-yARG(time)).gt.abs(zj(jzARG(time)+1)-yARG(time))) &
         & jzARG(time)=jzARG(time)+1
    end if
    end do
    !jzARG(18)=jzARG(18)-1


  open (43, file='simulARG.dat')
! Initial States
    jz=jzARG(1)
    ytarget=zj(jz)
    atarget=a_aver2

    write(43,*) ' --------------------'
    write(43,*) ' PATHS '
    write(43,*) ' --------------------'
    write(43,*) 'time, y,  z, a, b, d,  c, spr '

 do time=1, horizonARG-1

    z(time)=zj(jz)
    a(time)=atarget
    y(time)=ytarget

    b(time)= blip(yj,Aj,BD_c(:,:,jz),y(time),a(time))
    d(time)= blip(yj,Aj,DD_c(:,:,jz),y(time),a(time))*a(time)


!!!!!! take dscontonuotui into account

    if(b(time).ge.Bj(nBzero)) then !04aug14 !01dec15
        qqqtil=lininterp3(Bj(1:nB),Dj(1:nD),Aj(1:nA), &  !10jul14
                &   qq(1:nB,1:nD,1:nA,jz), &
                &   b(time),d(time),a(time)) !10jul14
    else
      if(nobuybacks.eq.1) then !30nov15
        qqqtil=q0/(one-q0*delta) !10apr14
      else if(nobuybacks.eq.0) then !01dec15
        qqqtil=lininterp3(Bj(1:nB),Dj(1:nD),Aj(1:nA), &
                &   qq(1:nB,1:nD,1:nA,jz), &
                &   b(time),d(time),a(time))
      end if
    end if


    q(time)=qqqtil
    spread(time)= (((one/qqqtil)+delta)**modelfreq)-((one/q0)**modelfreq)
    c(time)=y(time)-(a(time)-d(time)) &
        & +qqqtil*b(time)
    tb(time)=y(time)-c(time)

    ! .. write stuff ..
    write(43,'( &
                    & i6,f10.6,f10.6,f10.6, &
                    & f10.6,f10.6, &
                    & f10.6,f10.6)') &
        & time, y(time),  z(time), a(time), &
        & b(time), d(time), &
        & c(time), spread(time)


    !Next period states
    jzpr=jzARG(time+1)
    jz=jzpr
    atarget=b(time)+(one-delta)* Rbar_aver*d(time)+max(delta*a(time),zero)
    ytarget=zj(jzpr)*psi(d(time),jzpr,atarget) !07jun15 !06mar14

 end do !time

 close(43)
 deallocate(z,a,y,b,d,c,q,tb)

 end subroutine simul_ARG_old


!*******************************************************
!Set:
!   z_aver - make it global
!   iRARG(time) path
!   argy_70_06.txt should be quarterly (say argy_70_06_qrt.txt)

 subroutine simul_ARG
 use interp
 implicit none
 real(prec) :: z_aver
 integer :: time
 integer, parameter :: horizonARG=37
 real(prec), dimension(:), allocatable:: logdevy(:), yARG(:)
 real(prec), dimension(:), allocatable:: jzARG(:), iRARG(:)
 real(prec), dimension(:), allocatable :: RRbar(:)
 real(prec) :: parsum, qqqtil
 integer :: japr, jypr, jzpr

 real(prec) :: vtemp_ND, vtemp_D
 integer :: jylow, jyup, jalow, jaup

 real(prec), dimension(:), allocatable :: z(:),a(:),y(:),b(:),d(:),c(:),spread(:),tb(:),q(:)
 real(prec), dimension(:), allocatable :: partdef(:)

 real(prec) :: atarget, ytarget

    allocate (z(horizonARG),a(horizonARG),y(horizonARG),b(horizonARG), &
        &   d(horizonARG),c(horizonARG),q(horizonARG),tb(horizonARG),spread(horizonARG))

 allocate(logdevy(horizonARG), yARG(horizonARG), jzARG(horizonARG), iRARG(horizonARG) )
 allocate(RRbar(horizonARG),partdef(horizonARG))

    ! .. Define exogenous path of productivity jz ..
    z_aver= 0.5_prec !sum(z(1:ntime))/ntime

    open (298, file='argy_70_06.txt', status='old')
    read(298,*)
    do time=1, horizonARG
        read (298, *) logdevy(time)
        yARG(time)=exp(logdevy(time))*z_aver
    end do
    close(298)

    do time=1, horizonARG
    jzARG(time)=count(zj.le.yARG(time))
    if(jzARG(time).lt.nz) then
        if(abs(zj(jzARG(time))-yARG(time)).gt.abs(zj(jzARG(time)+1)-yARG(time)))        &
         & jzARG(time)=jzARG(time)+1
    end if
    end do

    ! .. Define exogenous path of recovery iR ..
    do time=1, horizonARG
    iRARG(time)=1
    end do

  open (43, file='simulARG.dat')

    ! .. Initial States ..
    jz=jzARG(1)
    ytarget=zj(jz)
    atarget=a_aver2

    write(43,*) ' --------------------'
    write(43,*) ' PATHS '
    write(43,*) ' --------------------'
    write(43,*) 'time, y,  z, a, b, d,  c, spr '

 do time=1, horizonARG-1

    ! [0] .. States ..
    z(time)=zj(jz)
    a(time)=atarget
    y(time)=ytarget

    ! [2] .. Current Rbar ..
    iR=iRARG(time)
    RRbar(time)=Rbar(iR)

    ! [3] .. endogenous decision and prices..
!    b(time)= blip(yj,Aj,BD_c(:,:,jz),y(time),a(time))
!    d(time)= blip(yj,Aj,DD_c(:,:,jz),y(time),a(time))*a(time)
    ! .. locate box containing (yypr, aapr)
    jylow=count(yj.le.y(time))
    jyup=min(jylow+1,ny)
    jalow=count(Aj.le.a(time))
    jaup=min(jalow+1,nA)
   if(D01(jyup,jalow,jz).eq.1) then   !default
    b(time)= blip(yj,Aj,BD_c(:,:,jz),y(time),a(time))
    d(time)= blip(yj,Aj,DD_c(:,:,jz),y(time),a(time))*a(time)
   else if (D01(jylow,jaup,jz).eq.0) then       !no-default
    b(time)= blip(yj,Aj,BND_c(:,:,jz),y(time),a(time))
    d(time)=zero
   else
    vtemp_ND=blip(yj,Aj,vND(:,:,jz),y(time),a(time))
    vtemp_D =blip(yj,Aj, vD(:,:,jz),y(time),a(time))
    if ( vtemp_ND.ge.vtemp_D) then
     b(time)= blip(yj,Aj,BND_c(:,:,jz),y(time),a(time))
     d(time)= zero
    else
     b(time)= blip(yj,Aj,BD_c(:,:,jz),y(time),a(time))
     d(time)= blip(yj,Aj,DD_c(:,:,jz),y(time),a(time))*a(time)
    end if
   end if

    if(a(time).gt.zero) then
        partdef(time)=d(time)/a(time)!15oct14
    else
        partdef(time)=zero
    end if



    if(b(time).ge.Bj(nBzero)) then !04aug14 !01dec15
        qqqtil=lininterp3(Bj(1:nB),Dj(1:nD),Aj(1:nA), &  !10jul14
                &   qq(1:nB,1:nD,1:nA,jz), &
                &   b(time),partdef(time),a(time)) !10jul14
    else
      if(nobuybacks.eq.1) then !30nov15
        qqqtil=q0/(one-q0*delta) !10apr14
      else if(nobuybacks.eq.0) then !01dec15
        qqqtil=lininterp3(Bj(1:nB),Dj(1:nD),Aj(1:nA), &
                &   qq(1:nB,1:nD,1:nA,jz), &
                &   b(time),partdef(time),a(time))
      end if
    end if


    q(time)=qqqtil
    spread(time)= (((one/qqqtil)+delta)**modelfreq)-((one/q0)**modelfreq)
    c(time)=y(time)-(a(time)-d(time)) &
        & +qqqtil*b(time)
    tb(time)=y(time)-c(time)

    ! .. write stuff ..
    write(43,'( &
                    & i6,f10.6,f10.6,f10.6, &
                    & f10.6,f10.6, &
                    & f10.6, &
                    & f10.6,f10.6)') &
        & time, y(time),  z(time), a(time), &
        & b(time), d(time), &
        & RRbar(time),  &
        & c(time), spread(time)


    ![4] .. Next period states ..
    jzpr=jzARG(time+1)
    jz=jzpr
    atarget=max(A(1),b(time)+(one-delta)*RRbar(time)*d(time)+max(delta*a(time),zero))
    ytarget=min(zj(jzpr)*psi(partdef(time),jzpr,atarget),yj(ny))

 end do !time

 close(43)
 deallocate(z,a,y,b,d,c,q,tb)

 end subroutine simul_ARG



!*******************************************************
! [14.] CALIBRATION
!*******************************************************
!04dec13
 function lossf(param_dum,nparam_dum)
    implicit none
    real(prec) ::  lossf    !16oct14 Rbar_dum,
    integer :: nparam_dum
    real(prec) :: param_dum(nparam_dum)

    ! .. loss to be minimised ..
    ! Targets: AtoY, Spr,freqdef, arrears
    ! Parameters to calibrate:

!    write(*,*) 'param', param_dum

    if ( &
!     &  (param_dum(1).le.0.0_prec ).or. &
!     &  (param_dum(2).ge.1.0_prec+small ).or. &
     &  (param_dum(1).le.0.0_prec ).or. &
     &  (param_dum(2).lt.(1.00_prec-small) ).or. &
!     &  (param_dum(2).le.0.0_prec ).or. &
     &  (param_dum(3).le.0.0_prec ).or.(param_dum(3).ge.1.0_prec ) &
!     &  .or.(param_dum(4).le.0.0_prec ).or.(param_dum(5).le.0.0_prec ) &
!     &  .or.(param_dum(5).ge.1.0_prec )      &
     & ) then
        lossf=+huge
    else
!        Rbar=param_dum(1)
!        psi0(:)=param_dum(2)
        phi1=param_dum(1)
        gamma_psi=param_dum(2)
!        upperdef=param_dum(2)
        Psimin=param_dum(3)
!!        beta=param_dum(4) !18jan15

!        chiB=param_dum(4)
!        mu=param_dum(5)

        call initstuff
        call prices_iter
        call simul_paths !(simulsize)  !18feb17

!!        lossf=sqrt(&
!!            &   ((AtoY-.05_prec)/.05_prec)**2._prec+ &
!!            &   ((Spr-.15_prec)/.15_prec)**2._prec+ &
!!            &   ((freqdef-.70_prec)/.70_prec)**2._prec+ &
!!            &   ((arrears-.68_prec)/.68_prec)**2._prec &
!!            & )
        lossf=sqrt(&
            &   3.0_prec*((AtoY-.05_prec))**2._prec+ &
            &   ((Spr-.10_prec))**2._prec+ &
            &   ((freqdef-.70_prec))**2._prec+ &
            &   ((arrears-.70_prec))**2._prec &
            & )
    end if
!!        if((AtoY.gt.0.17_prec).or.(arrears.gt.0.75_prec)) lossf=huge !06jan14
!!        if((AtoY.gt.0.17_prec)) lossf=huge !06jan14

       write(44,'(i6,12f9.4)') step_calib, Rbar_aver, psi0(1), phi1, gamma_psi, Psimin, mu, chiB, lossf, &
        & AtoY, Spr, freqdef, arrears
    step_calib=step_calib+1
 end function lossf
!*******************************************************
  subroutine caliboutput
   open (44, file='calib_out.dat')
    write(44,*) 'write other parameters '
    write(44,'(a5,f6.3,a3,i3,a4,i3)') 'dist=',gridA_dist, 'n=', nA,'ny=', ny
    write(44,'(a9,f8.5,a9,i2,a9,f8.5)') 'voldtol=', voldtol, 'finiteec=', finiteec, 'speedq=', speed_adjq
    write(44,'(a5,f6.3,a5,f6.3,a5,f6.3)') 'int=', (1.0/q0)-1, 'sig=', sigma, 'beta=', beta
    write(44,'(a5,f6.3)') 'del=', delta
    write(44,'(a8,f6.3,a8,f6.3,a8,f6.3)') 'chiL=', chiL, 'sd_B=', sd_B, 'sd_L=', sd_L
    write(44,'(a5,i6)') 'j_star=',   jzstar


    write(44,'(a6,10a9,5a6,a6)') 'step',  'Rbar',  'phi1', 'gamma',  'Psimin', 'beta ', 'loss', &
            & 'AtoY', 'Spr', 'freqdef', 'arrears', &
            & 'defsd ', 'sprsd ', & !01apr16
            & 'debtsd', & !09oct17
            & 'r_yspr', 'sdC', &
            & 'smalld' !11may18
        !01apr16     & 'dspr', 'ySpr', 'sprtb', 'dy', 'tby' !17oct14

  end subroutine caliboutput

!!*   subroutine dfovec_calib(nparam_dum,mv,param_dum,v_err)
!!*    use mostly
!!*    implicit none
!!*    integer :: nparam_dum, mv
!!*    real(prec) :: v_err(mv)
!!*    real(prec) :: param_dum(nparam_dum)
!!*
!!*
!!*    ! .. loss to be minimised ..
!!*    ! Targets: AtoY, Spr,freqdef, arrears
!!*    ! Parameters to calibrate:
!!*        phi1=param_dum(1)
!!*        gamma_psi=param_dum(2)
!!*        Psimin=param_dum(3)
!!*
!!*        call initstuff
!!*        call prices_iter
!!*        call simul_paths
!!*
!!*        v_err(1)=   (AtoY-.05_prec)
!!*        v_err(2)=   (Spr-.10_prec)
!!*        v_err(3)=   (freqdef-.60_prec)
!!*        v_err(4)=   (arrears-.60_prec)
!!*
!!*    IF(ID==0) &
!!*    &   write(44,'(i6,12f9.4)') step_calib, Rbar, psi0(1), phi1, gamma_psi, Psimin, mu, chiB,  &
!!*        & sqrt(sum(v_err(:)**2._prec)), &
!!*        & AtoY, Spr, freqdef, arrears
!!*    step_calib=step_calib+1
!!*   end subroutine dfovec_calib

! ************************************************************
!14feb21
 subroutine calib_bobyqa_case1
  use tauchen_mod
  use bobyqa_module
  implicit none

 !
 ! ..  calib related ..
 !
   real(prec) :: rhobeg, rhoend
   integer :: iprint, maxfun, npt, nparam !,mv
   real(prec), dimension(:), allocatable :: param(:)
   real(prec), dimension(:), allocatable :: paraml(:), paramu(:)
   real(prec) :: val_bobyqa

   IF(ID==0) THEN
    open(44, file='calib_bobyqa_case1.dat')
   END IF

 !
 ! .. Set number parameters and targets ..
 !
    nparam=5
    mv=10
    npt=2*nparam+1
    maxfun = 400*(nparam+1)
    allocate(paraml(nparam),paramu(nparam))
    allocate(param(nparam))

 !
 ! .. region search parameters ..
 !
    rhobeg= 0.40_prec !0.20_prec !0.05_prec
    rhoend= 0.01_prec !rhoend= 0.010_prec !0.0010_prec !0.0001_prec
    iprint=0

 !
 ! .. target values ..
 !
    AtoY_dat=       0.072_prec
    freqdef_dat=    0.35_prec
    arrears_dat=    0.345_prec
    sprstdv_dat=    0.036_prec
    debtstdv_dat=   0.210_prec
    dstdv_dat=      0.160_prec
    corrSpr_dat=    -0.29_prec
    Spr_dat=       0.0353_prec
    sdC_dat=         0.97_prec
    smalldef_dat=    0.04_prec

 !
 ! .. initial params ..
 !
	phi1=0.2061_prec
	gamma_psi=1.6209_prec
	Psimin=0.9598_prec
	beta=0.9872_prec
	Rbar(1)=0.9257_prec

 !
 ! .. bounds ..
 !
     phi1_l=0.15_prec
     phi1_h=0.2518_prec
     gamma_l=1.1_prec
     gamma_h=2.1748_prec
     Psimin_l=0.93_prec
     Psimin_h=0.9862_prec
     beta_l=0.98_prec
     beta_h=0.9942_prec
     Rbar_h=0.9314_prec
     Rbar_l=0.92_prec

    ! .. Write out calibration options ..
    IF(ID==0) THEN
    write(44,*) '--------------------------------'
    write(44,*)  'CALIBRATION SETTINGS '
    write(44,*) '--------------------------------'
    write(44,*) 'assigned param : '
    write(44,'(a15,f10.6)') 'q0= ', q0
    write(44,'(a15,f10.6)') 'delta= ' ,delta
    write(44,*) 'fixed param : '
    write(44,'(a15,f10.6)') 'rhoz= ',   rhoz
    write(44,'(a15,f10.6)') 'sdeta= ',  sdeta
    write(44,'(a15,i10)') 'jzstar= ', jzstar
    write(44,*) '--------------------------------'
    write(44,*) 'param and targets: '
    write(44,*) 'number of param ', nparam
    write(44,*) 'number of targets ', mv
    write(44,*) '--------------------------------'
    write(44,*) 'search radius: '
    write(44,'(a15,f10.6)') 'rhobeg= ', rhobeg
    write(44,'(a15,f10.6)') 'rhoend= ', rhoend
    write(44,*) '--------------------------------'
    write(44,*) 'Calibration targets '
    write(44,'(a15,f10.6)') ' AtoY_dat     ', AtoY_dat
    write(44,'(a15,f10.6)') ' freqdef_dat  ', freqdef_dat
    write(44,'(a15,f10.6)') ' arrears_dat  ', arrears_dat
    write(44,'(a15,f10.6)') ' sprstdv_dat  ', sprstdv_dat
    write(44,'(a15,f10.6)') ' debtstdv_dat ', debtstdv_dat
    write(44,'(a15,f10.6)') ' dstdv_dat    ', dstdv_dat
    write(44,'(a15,f10.6)') ' corrSpr_dat  ', corrSpr_dat
    write(44,'(a15,f10.6)') ' Spr_dat      ', Spr_dat
    write(44,'(a15,f10.6)') ' sdC_dat      ', sdC_dat
    write(44,'(a15,f10.6)') ' smalldef_dat ', smalldef_dat
    write(44,*) '--------------------------------'
    write(44,*) 'Initialisation parameters '
    write(44,'(a15,f10.6)') 'phi1     ',   phi1
    write(44,'(a15,f10.6)') 'gamma_psi',   gamma_psi
    write(44,'(a15,f10.6)') 'Psimin   ',   Psimin
    write(44,'(a15,f10.6)') 'beta     ',   beta
    write(44,'(a15,f10.6)') 'Rbar(1)  ',   Rbar(1)
    write(44,*) '--------------------------------'
    write(44,*) 'Bounds for parameters '
    write(44,'(a15,2f10.6)') 'phi1     ',   phi1_l  ,  phi1_h
    write(44,'(a15,2f10.6)') 'gamma_psi',   gamma_l ,  gamma_h
    write(44,'(a15,2f10.6)') 'Psimin   ',   Psimin_l,  Psimin_h
    write(44,'(a15,2f10.6)') 'beta     ',   beta_l  ,  beta_h
    write(44,'(a15,2f10.6)') 'Rbar(1)  ',   Rbar_l  ,  Rbar_h
    write(44,*) '--------------------------------'
    END IF

    ! .. Normalise parameters ..
     param(1)=(phi1-phi1_l)/(phi1_h-phi1_l)
     param(2)=(gamma_psi-gamma_l)/(gamma_h-gamma_l)
     param(3)=(Psimin-Psimin_l)/(Psimin_h-Psimin_l)
     param(4)=(beta-beta_l)/(beta_h-beta_l)
     param(5)=(Rbar(1)-Rbar_l)/(Rbar_h-Rbar_l)

     paraml(:)=0.0_prec
     paramu(:)=1.0_prec

    ! .. Header of table ..
    IF(ID==0) THEN
    write(44,*)
    write(44,'(a6,10a9,5a6,a6)') 'step',  'Rbar',  'phi1', 'gamma',  'Psimin', 'beta ', 'loss', &
            & 'AtoY', 'Spr', 'freqdef', 'arrears', &
            & 'defsd ', 'sprsd ', &
            & 'debtsd', &
            & 'r_yspr', 'sdC', &
            & 'smalld'
    END IF

    ! .. bobyqa minimisation ..
    step_calib=1
    call bobyqa (nparam, npt, param, paraml, paramu, rhobeg,rhoend,iprint,maxfun)
    IF(ID==0) THEN
    write(44,*)
    write(44,*) 'COMPLETED! '
    END IF

     ! .. report final outcome ..
    IF(ID==0) THEN
    write(44,*) 'param phi, gam, Psimin, beta, Rbar ', &
        &   (phi1_h-phi1_l)*param(1)+phi1_l, (gamma_h-gamma_l)*param(2)+gamma_l, &
        &   (Psimin_h-Psimin_l)*param(3)+Psimin_l, & !13jan15
        &   (beta_h-beta_l)*param(4)+beta_l, & !18jan15
        &   (Rbar_h-Rbar_l)*param(5)+Rbar_l
    END IF

    ! .. recompute calibrated outcomes ..
    call calfun(nparam, param, val_bobyqa)
    IF(ID==0) THEN
    write(44,*) 'param from dfovec ', phi1,  gamma_psi, Psimin, beta, Rbar(1)
    END IF

 end subroutine calib_bobyqa_case1

!**************************************************************************
!14feb21
 subroutine calib_bobyqa_case2
  use tauchen_mod
  use bobyqa_module
  implicit none

 !
 ! ..  calib related ..
 !
   real(prec) :: rhobeg, rhoend
   integer :: iprint, maxfun, npt, nparam !,mv
   real(prec), dimension(:), allocatable :: param(:)
   real(prec), dimension(:), allocatable :: paraml(:), paramu(:)
   real(prec) :: val_bobyqa
   real(prec) :: kappa, rr

   IF(ID==0) THEN
    open(44, file='calib_bobyqa_case2.dat')
   END IF

 !
 ! .. Set number parameters and targets ..
 !
    nparam=4
    mv=5
    npt=2*nparam+1
    maxfun = 400*(nparam+1)
    allocate(paraml(nparam),paramu(nparam))
    allocate(param(nparam))

 !
 ! .. region search parameters ..
 !
    rhobeg= 0.40_prec
    rhoend= 0.01_prec  !0.0010_prec !0.0001_prec
    iprint=0

 !
 ! .. target values ..
 !
    DebttoY_dat=    0.320_prec

    AtoY_dat=       0.050_prec
    freqdef_dat=    0.340_prec
    arrears_dat=    0.340_prec
    debtstdv_dat=   0.180_prec
    dstdv_dat=      0.160_prec
!*    sprstdv_dat=    0.036_prec
!*    corrSpr_dat=    -0.29_prec
!*    Spr_dat=       0.0353_prec
!*    sdC_dat=         0.97_prec
!*    smalldef_dat=    0.04_prec

 !
 ! .. assigned param ..
 !
    kappa=0.75_prec
    rr=0.0045_prec
    q0=one/(rr+one)

 !
 ! .. direct params ..
 !
    delta=one/q0-(one/q0)*(AtoY_dat/DebttoY_dat)/modelfreq
    Rbar(1)=kappa*((one/q0)-delta)/(one-delta)
    Rbar(1:nR)=Rbar(1)
    Rbar_aver=sum(Rbar(1:nR)*piR(1:nR))/nR

 !
 ! .. fixed param ..
 !
    jzstar=4
    rhoz=0.968546928_prec       !0.929_prec
    sdeta=0.018815693_prec      !0.0247_prec
    call tauchen(zero, sdeta, rhoz, 3.0_prec, nz, zj, piz)
    zj(1:nz)=exp(zj(1:nz))/two
 !
 ! .. initial params ..
 !
	phi1=0.2061_prec       !0.168425180820890_prec
	gamma_psi=1.6209_prec  !2.170_prec
	Psimin=0.9598_prec     !0.960217312170709_prec
	beta=0.9872_prec       !0.9940_prec
!*	  Rbar(1)=0.9257_prec

 !
 ! .. bounds ..
 !
     phi1_l=0.15_prec   !0.12_prec
     phi1_h=0.2518_prec !0.22_prec
     gamma_l=1.1_prec   !2.050_prec
     gamma_h=2.1748_prec !2.300_prec
     Psimin_l=0.93_prec
     Psimin_h=0.9862_prec
     beta_l=0.98_prec        !0.990_prec
     beta_h=0.9942_prec      !.9980_prec
!*     Rbar_h=0.9314_prec
!*     Rbar_l=0.92_prec

    ! .. Write out calibration options ..
    IF(ID==0) THEN
    write(44,*) '--------------------------------'
    write(44,*)  'CALIBRATION SETTINGS '
    write(44,*) '--------------------------------'
    write(44,*) 'assigned param : '
    write(44,'(a15,f10.6)') 'kappa= ' , kappa
    write(44,'(a15,f10.6)') 'r= ', rr
    write(44,'(a15,f10.6)') 'q0= ', q0
    write(44,*) 'direct param : '
    write(44,'(a15,f10.6)') 'delta= ' ,delta
    write(44,'(a15,f10.6)') 'Rbar= ', Rbar(1)
    write(44,*) 'fixed param : '
    write(44,'(a15,f10.6)') 'rhoz= ',   rhoz
    write(44,'(a15,f10.6)') 'sdeta= ',  sdeta
    write(44,'(a15,i10)')   'jzstar= ', jzstar
    write(44,*) '--------------------------------'
    write(44,*) '# calibrated param and targets: '
    write(44,*) 'number of param ', nparam
    write(44,*) 'number of targets ', mv
    write(44,*) '--------------------------------'
    write(44,*) 'search radius: '
    write(44,'(a15,f10.6)') 'rhobeg= ', rhobeg
    write(44,'(a15,f10.6)') 'rhoend= ', rhoend
    write(44,*) '--------------------------------'
    write(44,*) 'Calibration targets '
    write(44,'(a15,f10.6)') ' DebttoY_dat     ', DebttoY_dat
    write(44,'(a15,f10.6)') ' AtoY_dat     ', AtoY_dat
    write(44,'(a15,f10.6)') ' freqdef_dat  ', freqdef_dat
    write(44,'(a15,f10.6)') ' arrears_dat  ', arrears_dat
    write(44,'(a15,f10.6)') ' debtstdv_dat ', debtstdv_dat
    write(44,'(a15,f10.6)') ' dstdv_dat    ', dstdv_dat
!*    write(44,'(a15,f10.6)') ' sprstdv_dat  ', sprstdv_dat
!*    write(44,'(a15,f10.6)') ' corrSpr_dat  ', corrSpr_dat
!*    write(44,'(a15,f10.6)') ' Spr_dat      ', Spr_dat
!*    write(44,'(a15,f10.6)') ' sdC_dat      ', sdC_dat
!*    write(44,'(a15,f10.6)') ' smalldef_dat ', smalldef_dat
    write(44,*) '--------------------------------'
    write(44,*) 'Initialisation parameters '
    write(44,'(a15,f10.6)') 'phi1     ',   phi1
    write(44,'(a15,f10.6)') 'gamma_psi',   gamma_psi
    write(44,'(a15,f10.6)') 'Psimin   ',   Psimin
    write(44,'(a15,f10.6)') 'beta     ',   beta
!!*    write(44,'(a15,f10.6)') 'Rbar(1)  ',   Rbar(1)
    write(44,*) '--------------------------------'
    write(44,*) 'Bounds for parameters '
    write(44,'(a15,2f10.6)') 'phi1     ',   phi1_l  ,  phi1_h
    write(44,'(a15,2f10.6)') 'gamma_psi',   gamma_l ,  gamma_h
    write(44,'(a15,2f10.6)') 'Psimin   ',   Psimin_l,  Psimin_h
    write(44,'(a15,2f10.6)') 'beta     ',   beta_l  ,  beta_h
!!*    write(44,'(a15,2f10.6)') 'Rbar(1)  ',   Rbar_l  ,  Rbar_h
    write(44,*) '--------------------------------'
    END IF

    ! .. Normalise parameters ..
     param(1)=(phi1-phi1_l)/(phi1_h-phi1_l)
     param(2)=(gamma_psi-gamma_l)/(gamma_h-gamma_l)
     param(3)=(Psimin-Psimin_l)/(Psimin_h-Psimin_l)
     param(4)=(beta-beta_l)/(beta_h-beta_l)

     paraml(:)=0.0_prec
     paramu(:)=1.0_prec

    ! .. Header of table ..
    IF(ID==0) THEN
    write(44,*)
    write(44,'(a6,10a9,5a6,a6)') 'step',  'Rbar',  'phi1', 'gamma',  'Psimin', 'beta ', 'loss', &
            & 'AtoY', 'Spr', 'freqdef', 'arrears', &
            & 'defsd ', 'sprsd ', &
            & 'debtsd', &
            & 'r_yspr', 'sdC', &
            & 'smalld'
    END IF

    ! .. bobyqa minimisation ..
    step_calib=1
    call bobyqa (nparam, npt, param, paraml, paramu, rhobeg,rhoend,iprint,maxfun)
    IF(ID==0) THEN
    write(44,*)
    write(44,*) 'COMPLETED! '
    END IF

     ! .. report final outcome ..
    IF(ID==0) THEN
    write(44,*) 'param phi, gam, Psimin, beta ', &
        &   (phi1_h-phi1_l)*param(1)+phi1_l, (gamma_h-gamma_l)*param(2)+gamma_l, &
        &   (Psimin_h-Psimin_l)*param(3)+Psimin_l, & !13jan15
        &   (beta_h-beta_l)*param(4)+beta_l
    END IF

    ! .. recompute calibrated outcomes ..
    call calfun(nparam, param, val_bobyqa)
    IF(ID==0) THEN
    write(44,*) 'param from dfovec ', phi1,  gamma_psi, Psimin, beta
    END IF

 end subroutine calib_bobyqa_case2


!**************************************************************************
!14feb21
 subroutine calib_bobyqa_case3
  use tauchen_mod
  use bobyqa_module
  implicit none

 !
 ! ..  calib related ..
 !
   real(prec) :: rhobeg, rhoend
   integer :: iprint, maxfun, npt, nparam !,mv
   real(prec), dimension(:), allocatable :: param(:)
   real(prec), dimension(:), allocatable :: paraml(:), paramu(:)
   real(prec) :: val_bobyqa
   real(prec) :: kappa, rr

   IF(ID==0) THEN
    open(44, file='calib_bobyqa_case3.dat')
   END IF

 !
 ! .. Set number parameters and targets ..
 !
    nparam=4
    mv=6
    npt=2*nparam+1
    maxfun = 400*(nparam+1)
    allocate(paraml(nparam),paramu(nparam))
    allocate(param(nparam))

 !
 ! .. region search parameters ..
 !
    rhobeg= 0.40_prec
    rhoend= 0.01_prec  !0.0010_prec !0.0001_prec
    iprint=0

 !
 ! .. target values ..
 !
    DebttoY_dat=    0.320_prec

    AtoY_dat=       0.050_prec
    freqdef_dat=    0.340_prec
    arrears_dat=    0.340_prec
    debtstdv_dat=   0.180_prec
    dstdv_dat=      0.160_prec
    sprstdv_dat=    0.041_prec
!*    corrSpr_dat=    -0.29_prec
!*    Spr_dat=       0.0353_prec
!*    sdC_dat=         0.97_prec
!*    smalldef_dat=    0.04_prec

 !
 ! .. assigned param ..
 !
    kappa=0.75_prec
    rr=0.0045_prec
    q0=one/(rr+one)

 !
 ! .. direct params ..
 !
    delta=one/q0-(one/q0)*(AtoY_dat/DebttoY_dat)/modelfreq
    Rbar(1)=kappa*((one/q0)-delta)/(one-delta)
    Rbar(1:nR)=Rbar(1)
    Rbar_aver=sum(Rbar(1:nR)*piR(1:nR))/nR

 !
 ! .. fixed param ..
 !
    jzstar=4
    rhoz=0.968546928_prec       !0.929_prec
    sdeta=0.018815693_prec      !0.0247_prec
    call tauchen(zero, sdeta, rhoz, 3.0_prec, nz, zj, piz)
    zj(1:nz)=exp(zj(1:nz))/two

 !
 ! .. initial params ..
 !
	phi1=0.2061_prec       !0.168425180820890_prec
	gamma_psi=1.6209_prec  !2.170_prec
	Psimin=0.9598_prec     !0.960217312170709_prec
	beta=0.9872_prec       !0.9940_prec
!*	  Rbar(1)=0.9257_prec

 !
 ! .. bounds ..
 !
     phi1_l=0.15_prec   !0.12_prec
     phi1_h=0.2518_prec !0.22_prec
     gamma_l=1.1_prec   !2.050_prec
     gamma_h=2.1748_prec !2.300_prec
     Psimin_l=0.93_prec
     Psimin_h=0.9862_prec
     beta_l=0.98_prec        !0.990_prec
     beta_h=0.9942_prec      !.9980_prec
!*     Rbar_h=0.9314_prec
!*     Rbar_l=0.92_prec

    ! .. Write out calibration options ..
    IF(ID==0) THEN
    write(44,*) '--------------------------------'
    write(44,*)  'CALIBRATION SETTINGS '
    write(44,*) '--------------------------------'
    write(44,*) 'assigned param : '
    write(44,'(a15,f10.6)') 'kappa= ' , kappa
    write(44,'(a15,f10.6)') 'r= ', rr
    write(44,'(a15,f10.6)') 'q0= ', q0
    write(44,*) 'direct param : '
    write(44,'(a15,f10.6)') 'delta= ' ,delta
    write(44,'(a15,f10.6)') 'Rbar= ', Rbar(1)
    write(44,*) 'fixed param : '
    write(44,'(a15,f10.6)') 'rhoz= ',   rhoz
    write(44,'(a15,f10.6)') 'sdeta= ',  sdeta
    write(44,'(a15,i10)')   'jzstar= ', jzstar
    write(44,*) '--------------------------------'
    write(44,*) '# calibrated param and targets: '
    write(44,*) 'number of param ', nparam
    write(44,*) 'number of targets ', mv
    write(44,*) '--------------------------------'
    write(44,*) 'search radius: '
    write(44,'(a15,f10.6)') 'rhobeg= ', rhobeg
    write(44,'(a15,f10.6)') 'rhoend= ', rhoend
    write(44,*) '--------------------------------'
    write(44,*) 'Calibration targets '
    write(44,'(a15,f10.6)') ' DebttoY_dat     ', DebttoY_dat
    write(44,'(a15,f10.6)') ' AtoY_dat     ', AtoY_dat
    write(44,'(a15,f10.6)') ' freqdef_dat  ', freqdef_dat
    write(44,'(a15,f10.6)') ' arrears_dat  ', arrears_dat
    write(44,'(a15,f10.6)') ' debtstdv_dat ', debtstdv_dat
    write(44,'(a15,f10.6)') ' dstdv_dat    ', dstdv_dat
    write(44,'(a15,f10.6)') ' sprstdv_dat  ', sprstdv_dat
!*    write(44,'(a15,f10.6)') ' corrSpr_dat  ', corrSpr_dat
!*    write(44,'(a15,f10.6)') ' Spr_dat      ', Spr_dat
!*    write(44,'(a15,f10.6)') ' sdC_dat      ', sdC_dat
!*    write(44,'(a15,f10.6)') ' smalldef_dat ', smalldef_dat
    write(44,*) '--------------------------------'
    write(44,*) 'Initialisation parameters '
    write(44,'(a15,f10.6)') 'phi1     ',   phi1
    write(44,'(a15,f10.6)') 'gamma_psi',   gamma_psi
    write(44,'(a15,f10.6)') 'Psimin   ',   Psimin
    write(44,'(a15,f10.6)') 'beta     ',   beta
!!*    write(44,'(a15,f10.6)') 'Rbar(1)  ',   Rbar(1)
    write(44,*) '--------------------------------'
    write(44,*) 'Bounds for parameters '
    write(44,'(a15,2f10.6)') 'phi1     ',   phi1_l  ,  phi1_h
    write(44,'(a15,2f10.6)') 'gamma_psi',   gamma_l ,  gamma_h
    write(44,'(a15,2f10.6)') 'Psimin   ',   Psimin_l,  Psimin_h
    write(44,'(a15,2f10.6)') 'beta     ',   beta_l  ,  beta_h
!!*    write(44,'(a15,2f10.6)') 'Rbar(1)  ',   Rbar_l  ,  Rbar_h
    write(44,*) '--------------------------------'
    END IF

    ! .. Normalise parameters ..
     param(1)=(phi1-phi1_l)/(phi1_h-phi1_l)
     param(2)=(gamma_psi-gamma_l)/(gamma_h-gamma_l)
     param(3)=(Psimin-Psimin_l)/(Psimin_h-Psimin_l)
     param(4)=(beta-beta_l)/(beta_h-beta_l)

     paraml(:)=0.0_prec
     paramu(:)=1.0_prec

    ! .. Header of table ..
    IF(ID==0) THEN
    write(44,*)
    write(44,'(a6,10a9,5a6,a6)') 'step',  'Rbar',  'phi1', 'gamma',  'Psimin', 'beta ', 'loss', &
            & 'AtoY', 'Spr', 'freqdef', 'arrears', &
            & 'defsd ', 'sprsd ', &
            & 'debtsd', &
            & 'r_yspr', 'sdC', &
            & 'smalld'
    END IF

    ! .. bobyqa minimisation ..
    step_calib=1
    call bobyqa (nparam, npt, param, paraml, paramu, rhobeg,rhoend,iprint,maxfun)
    IF(ID==0) THEN
    write(44,*)
    write(44,*) 'COMPLETED! '
    END IF

     ! .. report final outcome ..
    IF(ID==0) THEN
    write(44,*) 'param phi, gam, Psimin, beta ', &
        &   (phi1_h-phi1_l)*param(1)+phi1_l, (gamma_h-gamma_l)*param(2)+gamma_l, &
        &   (Psimin_h-Psimin_l)*param(3)+Psimin_l, & !13jan15
        &   (beta_h-beta_l)*param(4)+beta_l
    END IF

    ! .. recompute calibrated outcomes ..
    call calfun(nparam, param, val_bobyqa)
    IF(ID==0) THEN
    write(44,*) 'param from dfovec ', phi1,  gamma_psi, Psimin, beta
    END IF

 end subroutine calib_bobyqa_case3


!**************************************************************************
!14feb21
 subroutine calib_bobyqa_case4
  use tauchen_mod
  use bobyqa_module
  implicit none

 !
 ! ..  calib related ..
 !
   real(prec) :: rhobeg, rhoend
   integer :: iprint, maxfun, npt, nparam !,mv
   real(prec), dimension(:), allocatable :: param(:)
   real(prec), dimension(:), allocatable :: paraml(:), paramu(:)
   real(prec) :: val_bobyqa
   real(prec) :: kappa, rr

   IF(ID==0) THEN
    open(44, file='calib_bobyqa_case4.dat')
   END IF

 !
 ! .. Set number parameters and targets ..
 !
    nparam=5
    mv=6
    npt=2*nparam+1
    maxfun = 400*(nparam+1)
    allocate(paraml(nparam),paramu(nparam))
    allocate(param(nparam))

 !
 ! .. region search parameters ..
 !
    rhobeg= 0.40_prec
    rhoend= 0.01_prec  !0.0010_prec !0.0001_prec
    iprint=0

 !
 ! .. target values ..
 !
    DebttoY_dat=    0.320_prec

    AtoY_dat=       0.050_prec
    freqdef_dat=    0.340_prec
    arrears_dat=    0.340_prec
    debtstdv_dat=   0.180_prec
    dstdv_dat=      0.160_prec
    sprstdv_dat=    0.041_prec
!*    corrSpr_dat=    -0.29_prec
!*    Spr_dat=       0.0353_prec
!*    sdC_dat=         0.97_prec
!*    smalldef_dat=    0.04_prec

 !
 ! .. assigned param ..
 !
!!*    kappa=0.75_prec
    rr=0.0045_prec
    q0=one/(rr+one)

 !
 ! .. direct params ..
 !
    delta=one/q0-(one/q0)*(AtoY_dat/DebttoY_dat)/modelfreq
!!*    Rbar(1)=kappa*((one/q0)-delta)/(one-delta)
!!*    Rbar(1:nR)=Rbar(1)
!!*    Rbar_aver=sum(Rbar(1:nR)*piR(1:nR))/nR

 !
 ! .. fixed param ..
 !
    jzstar=4
    rhoz=0.968546928_prec       !0.929_prec
    sdeta=0.018815693_prec      !0.0247_prec
    call tauchen(zero, sdeta, rhoz, 3.0_prec, nz, zj, piz)
    zj(1:nz)=exp(zj(1:nz))/two

 !
 ! .. initial params ..
 !
	phi1=0.2061_prec       !0.168425180820890_prec
	gamma_psi=1.6209_prec  !2.170_prec
	Psimin=0.9598_prec     !0.960217312170709_prec
	beta=0.9872_prec       !0.9940_prec
    Rbar(1)=0.9257_prec

 !
 ! .. bounds ..
 !
     phi1_l=0.15_prec   !0.12_prec
     phi1_h=0.2518_prec !0.22_prec
     gamma_l=1.1_prec   !2.050_prec
     gamma_h=2.1748_prec !2.300_prec
     Psimin_l=0.93_prec
     Psimin_h=0.9862_prec
     beta_l=0.98_prec        !0.990_prec
     beta_h=0.9942_prec      !.9980_prec
     Rbar_h=0.9314_prec
     Rbar_l=0.92_prec

    ! .. Write out calibration options ..
    IF(ID==0) THEN
    write(44,*) '--------------------------------'
    write(44,*)  'CALIBRATION SETTINGS '
    write(44,*) '--------------------------------'
    write(44,*) 'assigned param : '
    write(44,'(a15,f10.6)') 'r= ', rr
    write(44,'(a15,f10.6)') 'q0= ', q0
    write(44,*) 'direct param : '
    write(44,'(a15,f10.6)') 'delta= ' ,delta
    write(44,*) 'fixed param : '
    write(44,'(a15,f10.6)') 'rhoz= ',   rhoz
    write(44,'(a15,f10.6)') 'sdeta= ',  sdeta
    write(44,'(a15,i10)')   'jzstar= ', jzstar
    write(44,*) '--------------------------------'
    write(44,*) '# calibrated param and targets: '
    write(44,*) 'number of param ', nparam
    write(44,*) 'number of targets ', mv
    write(44,*) '--------------------------------'
    write(44,*) 'search radius: '
    write(44,'(a15,f10.6)') 'rhobeg= ', rhobeg
    write(44,'(a15,f10.6)') 'rhoend= ', rhoend
    write(44,*) '--------------------------------'
    write(44,*) 'Calibration targets '
    write(44,'(a15,f10.6)') ' DebttoY_dat     ', DebttoY_dat
    write(44,'(a15,f10.6)') ' AtoY_dat     ', AtoY_dat
    write(44,'(a15,f10.6)') ' freqdef_dat  ', freqdef_dat
    write(44,'(a15,f10.6)') ' arrears_dat  ', arrears_dat
    write(44,'(a15,f10.6)') ' debtstdv_dat ', debtstdv_dat
    write(44,'(a15,f10.6)') ' dstdv_dat    ', dstdv_dat
    write(44,'(a15,f10.6)') ' sprstdv_dat  ', sprstdv_dat
!*    write(44,'(a15,f10.6)') ' corrSpr_dat  ', corrSpr_dat
!*    write(44,'(a15,f10.6)') ' Spr_dat      ', Spr_dat
!*    write(44,'(a15,f10.6)') ' sdC_dat      ', sdC_dat
!*    write(44,'(a15,f10.6)') ' smalldef_dat ', smalldef_dat
    write(44,*) '--------------------------------'
    write(44,*) 'Initialisation parameters '
    write(44,'(a15,f10.6)') 'phi1     ',   phi1
    write(44,'(a15,f10.6)') 'gamma_psi',   gamma_psi
    write(44,'(a15,f10.6)') 'Psimin   ',   Psimin
    write(44,'(a15,f10.6)') 'beta     ',   beta
    write(44,'(a15,f10.6)') 'Rbar(1)  ',   Rbar(1)
    write(44,*) '--------------------------------'
    write(44,*) 'Bounds for parameters '
    write(44,'(a15,2f10.6)') 'phi1     ',   phi1_l  ,  phi1_h
    write(44,'(a15,2f10.6)') 'gamma_psi',   gamma_l ,  gamma_h
    write(44,'(a15,2f10.6)') 'Psimin   ',   Psimin_l,  Psimin_h
    write(44,'(a15,2f10.6)') 'beta     ',   beta_l  ,  beta_h
    write(44,'(a15,2f10.6)') 'Rbar(1)  ',   Rbar_l  ,  Rbar_h
    write(44,*) '--------------------------------'
    END IF

    ! .. Normalise parameters ..
     param(1)=(phi1-phi1_l)/(phi1_h-phi1_l)
     param(2)=(gamma_psi-gamma_l)/(gamma_h-gamma_l)
     param(3)=(Psimin-Psimin_l)/(Psimin_h-Psimin_l)
     param(4)=(beta-beta_l)/(beta_h-beta_l)
     param(5)=(Rbar(1)-Rbar_l)/(Rbar_h-Rbar_l)

     paraml(:)=0.0_prec
     paramu(:)=1.0_prec

    ! .. Header of table ..
    IF(ID==0) THEN
    write(44,*)
    write(44,'(a6,10a9,5a6,a6)') 'step',  'Rbar',  'phi1', 'gamma',  'Psimin', 'beta ', 'loss', &
            & 'AtoY', 'Spr', 'freqdef', 'arrears', &
            & 'defsd ', 'sprsd ', &
            & 'debtsd', &
            & 'r_yspr', 'sdC', &
            & 'smalld'
    END IF

    ! .. bobyqa minimisation ..
    step_calib=1
    call bobyqa (nparam, npt, param, paraml, paramu, rhobeg,rhoend,iprint,maxfun)
    IF(ID==0) THEN
    write(44,*)
    write(44,*) 'COMPLETED! '
    END IF

     ! .. report final outcome ..
    IF(ID==0) THEN
    write(44,*) 'param phi, gam, Psimin, beta, Rbar ', &
        &   (phi1_h-phi1_l)*param(1)+phi1_l, (gamma_h-gamma_l)*param(2)+gamma_l, &
        &   (Psimin_h-Psimin_l)*param(3)+Psimin_l, & !13jan15
        &   (beta_h-beta_l)*param(4)+beta_l, &
        &   (Rbar_h-Rbar_l)*param(5)+Rbar_l
    END IF

    ! .. recompute calibrated outcomes ..
    call calfun(nparam, param, val_bobyqa)
    IF(ID==0) THEN
    write(44,*) 'param from dfovec ', phi1,  gamma_psi, Psimin, beta, Rbar(1)
    END IF

 end subroutine calib_bobyqa_case4

!**************************************************************************
!14feb21
 subroutine calib_bobyqa_case5
  use tauchen_mod
  use bobyqa_module
  implicit none

 !
 ! ..  calib related ..
 !
   real(prec) :: rhobeg, rhoend
   integer :: iprint, maxfun, npt, nparam !,mv
   real(prec), dimension(:), allocatable :: param(:)
   real(prec), dimension(:), allocatable :: paraml(:), paramu(:)
   real(prec) :: val_bobyqa
   real(prec) :: kappa, rr, durat

   IF(ID==0) THEN
    open(44, file='calib_bobyqa_case5.dat')
   END IF

 !
 ! .. Set number parameters and targets ..
 !
    nparam=5
    mv=6
    npt=2*nparam+1
    maxfun = 400*(nparam+1)
    allocate(paraml(nparam),paramu(nparam))
    allocate(param(nparam))

 !
 ! .. region search parameters ..
 !
    rhobeg= 0.5_prec !0.40_prec
    rhoend= 0.01_prec  !0.0010_prec !0.0001_prec
    iprint=0

 !
 ! .. assigned param ..
 !
!!*    kappa=0.75_prec
    rr=0.010_prec       !0.0045_prec
    q0=one/(rr+one)
    durat= 5.0_prec
 !
 ! .. direct params ..
 !
    delta=one/q0-(one/q0)/(durat*modelfreq)

 !
 ! .. internal target values ..
 !
    DebttoY_dat=    0.320_prec
    AtoY_dat=DebttoY_dat/durat
    freqdef_dat=    0.340_prec
    arrears_dat=    0.340_prec
    debtstdv_dat=   0.180_prec
    dstdv_dat=      0.160_prec
    sprstdv_dat=    0.041_prec

 !
 ! .. other target values ..
 !
    logy_corr_dat=0.880_prec !0.968546928_prec (qrt)
    logy_sd_dat=0.100_prec  !0.075616365_prec (qrt)
!*    corrSpr_dat=    -0.29_prec
!*    Spr_dat=       0.0353_prec
!*    sdC_dat=         0.97_prec
    smalldef_dat=    0.04_prec


 !
 ! .. fixed param ..
 !
    jzstar=5 !4
    rhoz=0.952_prec     !0.968546928_prec       !0.929_prec
    sdeta=0.0249_prec   !0.018815693_prec      !0.0247_prec

    call tauchen(zero, sdeta, rhoz, 3.0_prec, nz, zj, piz)
    zj(1:nz)=exp(zj(1:nz))/two

 !
 ! .. initial params ..
 !
	phi1=0.2061_prec       !0.168425180820890_prec
	gamma_psi=1.6209_prec  !2.170_prec
	Psimin=0.9598_prec     !0.960217312170709_prec
	beta=0.9872_prec       !0.9940_prec
    Rbar(1)=0.9257_prec

	phi1=0.17_prec
	gamma_psi=2.10_prec
	Psimin=0.9473_prec
	beta=0.9872_prec
    Rbar(1)=0.9257_prec

	phi1=0.119_prec
	gamma_psi=2.10_prec
	Psimin=0.9473_prec
	beta=0.9872_prec
     Rbar(1)=0.9257_prec

 !
 ! .. bounds ..
 !
     phi1_l=0.15_prec   !0.12_prec
     phi1_h=0.2518_prec !0.22_prec
     gamma_l=1.1_prec   !2.050_prec
     gamma_h=2.1748_prec !2.300_prec
     Psimin_l=0.93_prec
     Psimin_h=0.9862_prec
     beta_l=0.98_prec        !0.990_prec
     beta_h=0.9942_prec      !.9980_prec
     Rbar_h=0.9314_prec
     Rbar_l=0.92_prec

     phi1_l=phi1*.70_prec
     phi1_h=phi1*1.30_prec
     gamma_l=gamma_psi*.70_prec
     gamma_h=gamma_psi*1.30_prec
	 Psimin_l=Psimin*.95_prec
     Psimin_h=Psimin*1.05_prec
     beta_l=0.98_prec
     beta_h=0.9942_prec
     Rbar_h=0.940_prec !0.9314_prec
     Rbar_l=0.91_prec !0.92_prec


if(modelfreq.eq.1) then !19feb21
    rr=0.040_prec
    q0=one/(rr+one)
    durat= 5.0_prec
    delta=one/q0-(one/q0)/(durat*modelfreq)
    rhoz=0.88_prec !0.82_prec
    sdeta=0.050_prec    !0.0614_prec
    call tauchen(zero, sdeta, rhoz, 3.0_prec, nz, zj, piz)
    zj(1:nz)=exp(zj(1:nz))/two
	beta=0.953629_prec
    beta_l=0.945_prec
    beta_h=0.965_prec
end if

    ! .. Write out calibration options ..
    IF(ID==0) THEN
    write(44,*) '--------------------------------'
    write(44,*)  'CALIBRATION SETTINGS '
    write(44,*) '--------------------------------'
    write(44,*) 'assigned param : '
    write(44,'(a15,f10.6)') 'r= ', rr
    write(44,'(a15,f10.6)') 'q0= ', q0
    write(44,*) 'direct param : '
    write(44,'(a15,f20.16)') 'delta= ' ,delta
    write(44,*) 'fixed param : '
    write(44,'(a15,f20.16)') 'rhoz= ',   rhoz
    write(44,'(a15,f20.16)') 'sdeta= ',  sdeta
    write(44,'(a15,i10)')   'jzstar= ', jzstar
    write(44,*) '--------------------------------'
    write(44,*) '# calibrated param and targets: '
    write(44,*) 'number of param ', nparam
    write(44,*) 'number of targets ', mv
    write(44,*) '--------------------------------'
    write(44,*) 'search radius: '
    write(44,'(a15,f10.6)') 'rhobeg= ', rhobeg
    write(44,'(a15,f10.6)') 'rhoend= ', rhoend
    write(44,*) '--------------------------------'
    write(44,*) 'Internal calibration targets '
    write(44,'(a15,f10.6)') ' DebttoY_dat     ', DebttoY_dat
    write(44,'(a15,f10.6)') ' AtoY_dat     ', AtoY_dat
    write(44,'(a15,f10.6)') ' freqdef_dat  ', freqdef_dat
    write(44,'(a15,f10.6)') ' arrears_dat  ', arrears_dat
    write(44,'(a15,f10.6)') ' debtstdv_dat ', debtstdv_dat
    write(44,'(a15,f10.6)') ' dstdv_dat    ', dstdv_dat
    write(44,'(a15,f10.6)') ' sprstdv_dat  ', sprstdv_dat
    write(44,*) '--------------------------------'
    write(44,*) 'Other calibration targets '
!*    write(44,'(a15,f10.6)') ' corrSpr_dat  ', corrSpr_dat
!*    write(44,'(a15,f10.6)') ' Spr_dat      ', Spr_dat
!*    write(44,'(a15,f10.6)') ' sdC_dat      ', sdC_dat
    write(44,'(a15,f10.6)') ' duration     ', durat
    write(44,'(a15,f10.6)') ' smalldef_dat ', smalldef_dat
    write(44,'(a15,f10.6)') ' logy_corr_dat ', logy_corr_dat
    write(44,'(a15,f10.6)') ' logy_sd_dat ', logy_sd_dat
    write(44,*) '--------------------------------'
    write(44,*) 'Initialisation parameters '
    write(44,'(a15,f10.6)') 'phi1     ',   phi1
    write(44,'(a15,f10.6)') 'gamma_psi',   gamma_psi
    write(44,'(a15,f10.6)') 'Psimin   ',   Psimin
    write(44,'(a15,f10.6)') 'beta     ',   beta
    write(44,'(a15,f10.6)') 'Rbar(1)  ',   Rbar(1)
    write(44,*) '--------------------------------'
    write(44,*) 'Bounds for parameters '
    write(44,'(a15,2f10.6)') 'phi1     ',   phi1_l  ,  phi1_h
    write(44,'(a15,2f10.6)') 'gamma_psi',   gamma_l ,  gamma_h
    write(44,'(a15,2f10.6)') 'Psimin   ',   Psimin_l,  Psimin_h
    write(44,'(a15,2f10.6)') 'beta     ',   beta_l  ,  beta_h
    write(44,'(a15,2f10.6)') 'Rbar(1)  ',   Rbar_l  ,  Rbar_h
    write(44,*) '--------------------------------'
    END IF

    ! .. Normalise parameters ..
     param(1)=(phi1-phi1_l)/(phi1_h-phi1_l)
     param(2)=(gamma_psi-gamma_l)/(gamma_h-gamma_l)
     param(3)=(Psimin-Psimin_l)/(Psimin_h-Psimin_l)
     param(4)=(beta-beta_l)/(beta_h-beta_l)
     param(5)=(Rbar(1)-Rbar_l)/(Rbar_h-Rbar_l)

     paraml(:)=0.0_prec
     paramu(:)=1.0_prec

    ! .. Header of table ..
    IF(ID==0) THEN
    write(44,*)
    write(44,'(a6,11a9,3a6,4a7)') 'step',  'Rbar',  'phi1', 'gamma',  'Psimin', 'beta ', 'sdeta', 'loss', &
            & 'AtoY', 'Spr', 'freqdef', 'arrears', &
            & 'defsd ', 'sprsd ', &
            & 'debtsd', &
            & 'r_yspr', 'sdC', &
            & 'smalld', 'y sd'
    END IF

    ! .. bobyqa minimisation ..
    step_calib=1
    call bobyqa (nparam, npt, param, paraml, paramu, rhobeg,rhoend,iprint,maxfun)
    IF(ID==0) THEN
    write(44,*)
    write(44,'(a25,f9.4)') 'Sd log inc ', sqrt(logy_var)
    write(44,'(a25,f9.4)') 'Autocorr log inc ', logy_corr
    write(44,*) 'COMPLETED! '
    END IF

     ! .. report final outcome ..
    IF(ID==0) THEN
    write(44,*) 'param phi, gam, Psimin, beta, Rbar ', &
        &   (phi1_h-phi1_l)*param(1)+phi1_l, (gamma_h-gamma_l)*param(2)+gamma_l, &
        &   (Psimin_h-Psimin_l)*param(3)+Psimin_l, & !13jan15
        &   (beta_h-beta_l)*param(4)+beta_l, &
        &   (Rbar_h-Rbar_l)*param(5)+Rbar_l
    END IF

    ! .. recompute calibrated outcomes ..
    call calfun(nparam, param, val_bobyqa)
    IF(ID==0) THEN
    write(44,*) 'param from dfovec ', phi1,  gamma_psi, Psimin, beta,  Rbar(1)
    END IF

 end subroutine calib_bobyqa_case5

!**************************************************************************
!14feb21
 subroutine calib_bobyqa_case6
  use tauchen_mod
  use bobyqa_module
  implicit none

 !
 ! ..  calib related ..
 !
   real(prec) :: rhobeg, rhoend
   integer :: iprint, maxfun, npt, nparam !,mv
   real(prec), dimension(:), allocatable :: param(:)
   real(prec), dimension(:), allocatable :: paraml(:), paramu(:)
   real(prec) :: val_bobyqa
   real(prec) :: kappa, rr, durat

   IF(ID==0) THEN
    open(44, file='calib_bobyqa_case6.dat')
   END IF

 !
 ! .. Set number parameters and targets ..
 !
    nparam=6
    mv=7
    npt=2*nparam+1
    maxfun = 400*(nparam+1)
    allocate(paraml(nparam),paramu(nparam))
    allocate(param(nparam))

 !
 ! .. region search parameters ..
 !
    rhobeg= 0.45_prec !0.20_prec !0.2_prec !0.5_prec !0.40_prec
    rhoend= 0.01_prec  !0.0010_prec !0.0001_prec
    iprint=0

 !
 ! .. assigned param ..
 !
!!*    kappa=0.75_prec
    rr=0.010_prec       !0.0045_prec
    q0=one/(rr+one)
    durat= 5.00_prec
 !
 ! .. direct params ..
 !
    delta=one/q0-(one/q0)/(durat*modelfreq)

 !
 ! .. internal target values ..
 !
    DebttoY_dat=    0.320_prec
    AtoY_dat=DebttoY_dat/durat
    freqdef_dat=    0.340_prec
    arrears_dat=    0.340_prec
    debtstdv_dat=   0.180_prec
    dstdv_dat=      0.160_prec
    sprstdv_dat=    0.041_prec
    logy_sd_dat=    0.100_prec  !0.075616365_prec (qrt)

 !
 ! .. other target values ..
 !
    logy_corr_dat=0.880_prec !0.968546928_prec (qrt)

!*    corrSpr_dat=    -0.29_prec
!*    Spr_dat=       0.0353_prec
!*    sdC_dat=         0.97_prec
    smalldef_dat=    0.04_prec


 !
 ! .. fixed param ..
 !
    jzstar=4 !5  !4
    rhoz=0.952_prec     !0.9672_prec     !0.968546928_prec       !0.929_prec
    sdeta=0.0249_prec   !0.0188_prec   !0.018815693_prec      !0.0247_prec

    call tauchen(zero, sdeta, rhoz, 3.0_prec, nz, zj, piz)
    zj(1:nz)=exp(zj(1:nz))/two

 !
 ! .. initial params ..
 !
	phi1=0.2061_prec       !0.168425180820890_prec
	gamma_psi=1.6209_prec  !2.170_prec
	Psimin=0.9598_prec     !0.960217312170709_prec
	beta=0.9872_prec       !0.9940_prec
    Rbar(1)=0.9257_prec

	phi1=0.17_prec
	gamma_psi=2.10_prec
	Psimin=0.9473_prec
	beta=0.9872_prec
    Rbar(1)=0.9257_prec

	phi1=0.119_prec
	gamma_psi=2.10_prec
	Psimin=0.9473_prec
	beta=0.9882_prec
     Rbar(1)=0.9257_prec

 !
 ! .. bounds ..
 !
     phi1_l=0.15_prec   !0.12_prec
     phi1_h=0.2518_prec !0.22_prec
     gamma_l=1.1_prec   !2.050_prec
     gamma_h=2.1748_prec !2.300_prec
     Psimin_l=0.93_prec
     Psimin_h=0.9862_prec
     beta_l=0.98_prec        !0.990_prec
     beta_h=0.9942_prec      !.9980_prec
     Rbar_h=0.9314_prec
     Rbar_l=0.92_prec

     phi1_l=phi1*.70_prec
     phi1_h=phi1*1.30_prec
     gamma_l=gamma_psi*.70_prec
     gamma_h=gamma_psi*1.30_prec
	 Psimin_l=Psimin*.95_prec
     Psimin_h=Psimin*1.05_prec
     beta_l=0.980_prec
     beta_h=0.996_prec
     Rbar_h=0.940_prec !0.9314_prec
     Rbar_l=0.91_prec !0.92_prec
     sdeta_l=0.0235_prec    !0.0180_prec
     sdeta_h=0.0263_prec    !0.0196_prec

if(modelfreq.eq.1) then !19feb21
    jzstar=5 !4
    rr=0.040_prec
    q0=one/(rr+one)
    durat= 5.00_prec !5.00_prec
    delta=one/q0-(one/q0)/(durat*modelfreq)
    rhoz=0.875_prec  !0.88_prec !0.82_prec
    sdeta=0.0475_prec !0.045_prec !0.050_prec    !0.0614_prec
    sdeta_l=0.0425_prec
    sdeta_h=0.0525_prec
    call tauchen(zero, sdeta, rhoz, 3.0_prec, nz, zj, piz)
    zj(1:nz)=exp(zj(1:nz))/two
	beta=0.953629_prec
    beta_l=0.945_prec
    beta_h=0.965_prec
end if

    ! .. Write out calibration options ..
    IF(ID==0) THEN
    write(44,*) '--------------------------------'
    write(44,*)  'CALIBRATION SETTINGS '
    write(44,*) '--------------------------------'
    write(44,*) 'assigned param : '
    write(44,'(a15,f10.6)') 'r= ', rr
    write(44,'(a15,f10.6)') 'q0= ', q0
    write(44,*) 'direct param : '
    write(44,'(a15,f20.16)') 'delta= ' ,delta
    write(44,*) 'fixed param : '
    write(44,'(a15,f20.16)') 'rhoz= ',   rhoz
    write(44,'(a15,i10)')   'jzstar= ', jzstar
    write(44,*) '--------------------------------'
    write(44,*) '# calibrated param and targets: '
    write(44,*) 'number of param ', nparam
    write(44,*) 'number of targets ', mv
    write(44,*) '--------------------------------'
    write(44,*) 'search radius: '
    write(44,'(a15,f10.6)') 'rhobeg= ', rhobeg
    write(44,'(a15,f10.6)') 'rhoend= ', rhoend
    write(44,*) '--------------------------------'
    write(44,*) 'Internal calibration targets '
    write(44,'(a15,f10.6)') ' DebttoY_dat     ', DebttoY_dat
    write(44,'(a15,f10.6)') ' AtoY_dat     ', AtoY_dat
    write(44,'(a15,f10.6)') ' freqdef_dat  ', freqdef_dat
    write(44,'(a15,f10.6)') ' arrears_dat  ', arrears_dat
    write(44,'(a15,f10.6)') ' debtstdv_dat ', debtstdv_dat
    write(44,'(a15,f10.6)') ' dstdv_dat    ', dstdv_dat
    write(44,'(a15,f10.6)') ' sprstdv_dat  ', sprstdv_dat
    write(44,'(a15,f10.6)') ' logy_sd_dat ', logy_sd_dat
    write(44,*) '--------------------------------'
    write(44,*) 'Other calibration targets '
!*    write(44,'(a15,f10.6)') ' corrSpr_dat  ', corrSpr_dat
!*    write(44,'(a15,f10.6)') ' Spr_dat      ', Spr_dat
!*    write(44,'(a15,f10.6)') ' sdC_dat      ', sdC_dat
    write(44,'(a15,f10.6)') ' duration     ', durat
    write(44,'(a15,f10.6)') ' smalldef_dat ', smalldef_dat
    write(44,'(a15,f10.6)') ' logy_corr_dat ', logy_corr_dat
    write(44,*) '--------------------------------'
    write(44,*) 'Initialisation parameters '
    write(44,'(a15,f10.6)') 'phi1     ',   phi1
    write(44,'(a15,f10.6)') 'gamma_psi',   gamma_psi
    write(44,'(a15,f10.6)') 'Psimin   ',   Psimin
    write(44,'(a15,f10.6)') 'beta     ',   beta
    write(44,'(a15,f10.6)') 'Rbar(1)  ',   Rbar(1)
    write(44,'(a15,f20.16)') 'sdeta= ',    sdeta
    write(44,*) '--------------------------------'
    write(44,*) 'Bounds for parameters '
    write(44,'(a15,2f10.6)') 'phi1     ',   phi1_l  ,  phi1_h
    write(44,'(a15,2f10.6)') 'gamma_psi',   gamma_l ,  gamma_h
    write(44,'(a15,2f10.6)') 'Psimin   ',   Psimin_l,  Psimin_h
    write(44,'(a15,2f10.6)') 'beta     ',   beta_l  ,  beta_h
    write(44,'(a15,2f10.6)') 'Rbar(1)  ',   Rbar_l  ,  Rbar_h
    write(44,'(a15,2f10.6)') 'sdeta     ',   sdeta_l  ,  sdeta_h
    write(44,*) '--------------------------------'
    END IF

    ! .. Normalise parameters ..
     param(1)=(phi1-phi1_l)/(phi1_h-phi1_l)
     param(2)=(gamma_psi-gamma_l)/(gamma_h-gamma_l)
     param(3)=(Psimin-Psimin_l)/(Psimin_h-Psimin_l)
     param(4)=(beta-beta_l)/(beta_h-beta_l)
     param(5)=(Rbar(1)-Rbar_l)/(Rbar_h-Rbar_l)
     param(6)=(sdeta-sdeta_l)/(sdeta_h-sdeta_l)

     paraml(:)=0.0_prec
     paramu(:)=1.0_prec

    ! .. Header of table ..
    IF(ID==0) THEN
    write(44,*)
    write(44,'(a6,11a9,3a6,4a7)') 'step',  'Rbar',  'phi1', 'gamma',  'Psimin', 'beta ', 'sdeta', 'loss', &
            & 'AtoY', 'Spr', 'freqdef', 'arrears', &
            & 'defsd ', 'sprsd ', &
            & 'debtsd', &
            & 'r_yspr', 'sdC', &
            & 'smalld', 'y sd'
    END IF

    ! .. bobyqa minimisation ..
    step_calib=1
    call bobyqa (nparam, npt, param, paraml, paramu, rhobeg,rhoend,iprint,maxfun)
    IF(ID==0) THEN
    write(44,*)
    write(44,'(a25,f9.4)') 'Sd log inc ', sqrt(logy_var)
    write(44,'(a25,f9.4)') 'Autocorr log inc ', logy_corr
    write(44,*) 'COMPLETED! '
    END IF

     ! .. report final outcome ..
    IF(ID==0) THEN
    write(44,*) 'param phi, gam, Psimin, beta, Rbar, sdeta ', &
        &   (phi1_h-phi1_l)*param(1)+phi1_l, (gamma_h-gamma_l)*param(2)+gamma_l, &
        &   (Psimin_h-Psimin_l)*param(3)+Psimin_l, & !13jan15
        &   (beta_h-beta_l)*param(4)+beta_l, &
        &   (Rbar_h-Rbar_l)*param(5)+Rbar_l, &
        &   (sdeta_h-sdeta_l)*param(6)+sdeta_l
    END IF

    ! .. recompute calibrated outcomes ..
    call calfun(nparam, param, val_bobyqa)
    IF(ID==0) THEN
    write(44,*) 'param from dfovec ', phi1,  gamma_psi, Psimin, beta,  Rbar(1), sdeta
    END IF

 end subroutine calib_bobyqa_case6
!**************************************************************************
!14feb21
 subroutine calib_bobyqa_case7
  use tauchen_mod
  use bobyqa_module
  implicit none

 !
 ! ..  calib related ..
 !
   real(prec) :: rhobeg, rhoend
   integer :: iprint, maxfun, npt, nparam !,mv
   real(prec), dimension(:), allocatable :: param(:)
   real(prec), dimension(:), allocatable :: paraml(:), paramu(:)
   real(prec) :: val_bobyqa
   real(prec) :: kappa, rr, durat

   IF(ID==0) THEN
    open(44, file='calib_bobyqa_case7.dat')
   END IF

 !
 ! .. Set number parameters and targets ..
 !
    nparam=6
    mv=7
    npt=2*nparam+1
    maxfun = 400*(nparam+1)
    allocate(paraml(nparam),paramu(nparam))
    allocate(param(nparam))

 !
 ! .. region search parameters ..
 !
    rhobeg= 0.45_prec  !0.5_prec !0.40_prec
    rhoend= 0.01_prec  !0.0010_prec !0.0001_prec
    iprint=0

 !
 ! .. assigned param ..
 !
!!*    kappa=0.75_prec
    rr=0.010_prec       !0.0045_prec
    q0=one/(rr+one)


 !
 ! .. internal target values ..
 !
    DebttoY_dat=    0.320_prec
    AtoY_dat=       0.050_prec
    freqdef_dat=    0.340_prec
    arrears_dat=    0.340_prec
    debtstdv_dat=   0.180_prec
    dstdv_dat=      0.160_prec
    sprstdv_dat=    0.041_prec
    logy_sd_dat=    0.100_prec  !0.075616365_prec (qrt)

!    sprstdv_dat=    0.041_prec/two

 !
 ! .. direct params ..
 !
    delta=one/q0-(one/q0)*(AtoY_dat/DebttoY_dat)/modelfreq

 !
 ! .. other target values ..
 !
    logy_corr_dat=0.880_prec !0.968546928_prec (qrt)
    smalldef_dat=    0.04_prec
    durat=((one/q0)/((one/q0)-delta))/modelfreq

 !
 ! .. fixed param ..
 !
    jzstar=4 !5
    rhoz=0.952_prec     !0.9672_prec     !0.968546928_prec       !0.929_prec
    sdeta=0.0249_prec   !0.0188_prec   !0.018815693_prec      !0.0247_prec

    call tauchen(zero, sdeta, rhoz, 3.0_prec, nz, zj, piz)
    zj(1:nz)=exp(zj(1:nz))/two

 !
 ! .. initial params ..
 !
	phi1=0.2061_prec       !0.168425180820890_prec
	gamma_psi=1.6209_prec  !2.170_prec
	Psimin=0.9598_prec     !0.960217312170709_prec
	beta=0.9872_prec       !0.9940_prec
    Rbar(1)=0.9257_prec

	phi1=0.17_prec
	gamma_psi=2.10_prec
	Psimin=0.9473_prec
	beta=0.9872_prec
    Rbar(1)=0.9257_prec

	phi1=0.119_prec
	gamma_psi=2.10_prec
	Psimin=0.9473_prec
	beta=0.9882_prec
     Rbar(1)=0.9257_prec

 !
 ! .. bounds ..
 !
     phi1_l=phi1*.70_prec
     phi1_h=phi1*1.30_prec
     gamma_l=gamma_psi*.70_prec
     gamma_h=gamma_psi*1.30_prec
	 Psimin_l=Psimin*.95_prec
     Psimin_h=Psimin*1.05_prec
     beta_l=0.980_prec
     beta_h=0.996_prec
     Rbar_h=0.940_prec !0.9314_prec
     Rbar_l=0.91_prec !0.92_prec
     sdeta_l=0.0235_prec    !0.0180_prec
     sdeta_h=0.0263_prec    !0.0196_prec

! expand?
     phi1_l=phi1*.20_prec
     phi1_h=phi1*1.80_prec
     gamma_l=gamma_psi*.20_prec
     gamma_h=gamma_psi*1.8_prec


if(modelfreq.eq.1) then !19feb21
    jzstar=5 !4
    rr=0.040_prec
    q0=one/(rr+one)
    delta=one/q0-(one/q0)*(AtoY_dat/DebttoY_dat)/modelfreq
    durat=((one/q0)/((one/q0)-delta))/modelfreq
    rhoz=0.875_prec  !0.88_prec !0.82_prec
    sdeta=0.0475_prec !0.045_prec !0.050_prec    !0.0614_prec
    call tauchen(zero, sdeta, rhoz, 3.0_prec, nz, zj, piz)
    zj(1:nz)=exp(zj(1:nz))/two
	beta=0.953629_prec

    beta_l=0.945_prec
    beta_h=0.965_prec
    sdeta_l=0.0425_prec
    sdeta_h=0.0525_prec
end if

    ! .. Write out calibration options ..
    IF(ID==0) THEN
    write(44,*) '--------------------------------'
    write(44,*)  'CALIBRATION SETTINGS '
    write(44,*) '--------------------------------'
    write(44,*) 'assigned param : '
    write(44,'(a15,f10.6)') 'r= ', rr
    write(44,'(a15,f10.6)') 'q0= ', q0
    write(44,*) 'direct param : '
    write(44,'(a15,f20.16)') 'delta= ' ,delta
    write(44,*) 'fixed param : '
    write(44,'(a15,f20.16)') 'rhoz= ',   rhoz
    write(44,'(a15,i10)')   'jzstar= ', jzstar
    write(44,*) '--------------------------------'
    write(44,*) '# calibrated param and targets: '
    write(44,*) 'number of param ', nparam
    write(44,*) 'number of targets ', mv
    write(44,*) '--------------------------------'
    write(44,*) 'search radius: '
    write(44,'(a15,f10.6)') 'rhobeg= ', rhobeg
    write(44,'(a15,f10.6)') 'rhoend= ', rhoend
    write(44,*) '--------------------------------'
    write(44,*) 'Internal calibration targets '
    write(44,'(a15,f10.6)') ' DebttoY_dat     ', DebttoY_dat
    write(44,'(a15,f10.6)') ' AtoY_dat     ', AtoY_dat
    write(44,'(a15,f10.6)') ' freqdef_dat  ', freqdef_dat
    write(44,'(a15,f10.6)') ' arrears_dat  ', arrears_dat
    write(44,'(a15,f10.6)') ' debtstdv_dat ', debtstdv_dat
    write(44,'(a15,f10.6)') ' dstdv_dat    ', dstdv_dat
    write(44,'(a15,f10.6)') ' sprstdv_dat  ', sprstdv_dat
    write(44,'(a15,f10.6)') ' logy_sd_dat ', logy_sd_dat
    write(44,*) '--------------------------------'
    write(44,*) 'Other calibration targets '
!*    write(44,'(a15,f10.6)') ' corrSpr_dat  ', corrSpr_dat
!*    write(44,'(a15,f10.6)') ' Spr_dat      ', Spr_dat
!*    write(44,'(a15,f10.6)') ' sdC_dat      ', sdC_dat
    write(44,'(a15,f10.6)') ' smalldef_dat ', smalldef_dat
    write(44,'(a15,f10.6)') ' logy_corr_dat ', logy_corr_dat
    write(44,*) '--------------------------------'
    write(44,*) 'Implied var '
    write(44,'(a15,f10.6)') ' duration     ', durat
    write(44,*) '--------------------------------'
    write(44,*) 'Initialisation parameters '
    write(44,'(a15,f10.6)') 'phi1     ',   phi1
    write(44,'(a15,f10.6)') 'gamma_psi',   gamma_psi
    write(44,'(a15,f10.6)') 'Psimin   ',   Psimin
    write(44,'(a15,f10.6)') 'beta     ',   beta
    write(44,'(a15,f10.6)') 'Rbar(1)  ',   Rbar(1)
    write(44,'(a15,f20.16)') 'sdeta= ',    sdeta
    write(44,*) '--------------------------------'
    write(44,*) 'Bounds for parameters '
    write(44,'(a15,2f10.6)') 'phi1     ',   phi1_l  ,  phi1_h
    write(44,'(a15,2f10.6)') 'gamma_psi',   gamma_l ,  gamma_h
    write(44,'(a15,2f10.6)') 'Psimin   ',   Psimin_l,  Psimin_h
    write(44,'(a15,2f10.6)') 'beta     ',   beta_l  ,  beta_h
    write(44,'(a15,2f10.6)') 'Rbar(1)  ',   Rbar_l  ,  Rbar_h
    write(44,'(a15,2f10.6)') 'sdeta     ',   sdeta_l  ,  sdeta_h
    write(44,*) '--------------------------------'
    END IF

    ! .. Normalise parameters ..
     param(1)=(phi1-phi1_l)/(phi1_h-phi1_l)
     param(2)=(gamma_psi-gamma_l)/(gamma_h-gamma_l)
     param(3)=(Psimin-Psimin_l)/(Psimin_h-Psimin_l)
     param(4)=(beta-beta_l)/(beta_h-beta_l)
     param(5)=(Rbar(1)-Rbar_l)/(Rbar_h-Rbar_l)
     param(6)=(sdeta-sdeta_l)/(sdeta_h-sdeta_l)

     paraml(:)=0.0_prec
     paramu(:)=1.0_prec

    ! .. Header of table ..
    IF(ID==0) THEN
    write(44,*)
    write(44,'(a6,11a9,3a6,4a7)') 'step',  'Rbar',  'phi1', 'gamma',  'Psimin', 'beta ', 'sdeta', 'loss', &
            & 'AtoY', 'Spr', 'freqdef', 'arrears', &
            & 'defsd ', 'sprsd ', &
            & 'debtsd', &
            & 'r_yspr', 'sdC', &
            & 'smalld', 'y sd'
    END IF

    ! .. bobyqa minimisation ..
    step_calib=1
    call bobyqa (nparam, npt, param, paraml, paramu, rhobeg,rhoend,iprint,maxfun)
    IF(ID==0) THEN
    write(44,*)
    write(44,'(a25,f9.4)') 'Sd log inc ', sqrt(logy_var)
    write(44,'(a25,f9.4)') 'Autocorr log inc ', logy_corr
    write(44,*) 'COMPLETED! '
    END IF

     ! .. report final outcome ..
    IF(ID==0) THEN
    write(44,*) 'param phi, gam, Psimin, beta, Rbar, sdeta ', &
        &   (phi1_h-phi1_l)*param(1)+phi1_l, (gamma_h-gamma_l)*param(2)+gamma_l, &
        &   (Psimin_h-Psimin_l)*param(3)+Psimin_l, & !13jan15
        &   (beta_h-beta_l)*param(4)+beta_l, &
        &   (Rbar_h-Rbar_l)*param(5)+Rbar_l, &
        &   (sdeta_h-sdeta_l)*param(6)+sdeta_l
    END IF

    ! .. recompute calibrated outcomes ..
    call calfun(nparam, param, val_bobyqa)
    IF(ID==0) THEN
    write(44,*) 'param from dfovec ', phi1,  gamma_psi, Psimin, beta,  Rbar(1), sdeta
    END IF

 end subroutine calib_bobyqa_case7
!**************************************************************************
!12oct21
 subroutine calib_bobyqa_case8
  use tauchen_mod
  use bobyqa_module
  implicit none

 !
 ! ..  calib related ..
 !
   real(prec) :: rhobeg, rhoend
   integer :: iprint, maxfun, npt, nparam !,mv
   real(prec), dimension(:), allocatable :: param(:)
   real(prec), dimension(:), allocatable :: paraml(:), paramu(:)
   real(prec) :: val_bobyqa
   real(prec) :: kappa, rr, durat

   IF(ID==0) THEN
    open(44, file='calib_bobyqa_case8.dat')
   END IF

 !
 ! .. Set number parameters and targets ..
 !
    nparam=6
    mv=9
    npt=2*nparam+1
    maxfun = 400*(nparam+1)
    allocate(paraml(nparam),paramu(nparam))
    allocate(param(nparam))

 !
 ! .. region search parameters ..
 !
    rhobeg= 0.45_prec  !0.5_prec !0.40_prec
    rhoend= 0.01_prec  !0.0010_prec !0.0001_prec
    iprint=0

 !
 ! .. assigned param ..
 !
!!*    kappa=0.75_prec
    rr=0.010_prec       !0.0045_prec
    q0=one/(rr+one)


 !
 ! .. internal target values ..
 !
    DebttoY_dat=    0.320_prec
    AtoY_dat=       0.050_prec
    freqdef_dat=    0.340_prec
    arrears_dat=    0.340_prec
    debtstdv_dat=   0.180_prec
    dstdv_dat=      0.160_prec
    sprstdv_dat=    0.041_prec
    logy_sd_dat=    0.100_prec  !0.075616365_prec (qrt)
    debtserv_dat=    0.036_prec
    debtserv_sd_dat= 0.021_prec

 !
 ! .. direct params ..
 !
    delta=one/q0-(one/q0)*(AtoY_dat/DebttoY_dat)/modelfreq

 !
 ! .. other target values ..
 !
    logy_corr_dat=0.880_prec !0.968546928_prec (qrt)
    smalldef_dat=    0.04_prec
    durat=((one/q0)/((one/q0)-delta))/modelfreq

 !
 ! .. fixed param ..
 !
    jzstar=4 !5
    rhoz=0.952_prec     !0.9672_prec     !0.968546928_prec       !0.929_prec
    sdeta=0.0249_prec   !0.0188_prec   !0.018815693_prec      !0.0247_prec

    call tauchen(zero, sdeta, rhoz, 3.0_prec, nz, zj, piz)
    zj(1:nz)=exp(zj(1:nz))/two

 !
 ! .. initial params ..
 !

	phi1=0.119_prec
	gamma_psi=2.10_prec
	Psimin=0.9473_prec
	beta=0.9882_prec
    Rbar(1)=0.9257_prec

 !
 ! .. bounds ..
 !
     phi1_l=phi1*.20_prec
     phi1_h=phi1*1.80_prec
     gamma_l=gamma_psi*.20_prec
     gamma_h=gamma_psi*1.8_prec
	 Psimin_l=Psimin*.95_prec
     Psimin_h=Psimin*1.05_prec
     beta_l=0.980_prec
     beta_h=0.996_prec
     Rbar_h=0.940_prec !0.9314_prec
     Rbar_l=0.91_prec !0.92_prec
     sdeta_l=0.0235_prec    !0.0180_prec
     sdeta_h=0.0263_prec    !0.0196_prec




if(modelfreq.eq.1) then !19feb21
    jzstar=5 !4
    rr=0.040_prec
    q0=one/(rr+one)
    delta=one/q0-(one/q0)*(AtoY_dat/DebttoY_dat)/modelfreq
    durat=((one/q0)/((one/q0)-delta))/modelfreq
    rhoz=0.875_prec  !0.88_prec !0.82_prec


!From ex15cA
!phi, gam, Psimin, beta, Rbar, sdeta
!phi 0.119127825519985
!gamm 1.99668319823033
!Psimin0.952384143594332
!Rbar 0.924240897135683
!sdeta 5.166620662932899E-002
!beta 0.953690526499050

	phi1=      0.119127825519985_prec  !0.119_prec
	gamma_psi= 1.99668319823033_prec   !2.10_prec
	Psimin=    0.952384143594332_prec  !0.9473_prec
    Rbar(1)=   0.924240897135683_prec  !0.9257_prec

    sdeta=0.05166620662932899_prec !0.0475_prec !0.045_prec !0.050_prec    !0.0614_prec
    call tauchen(zero, sdeta, rhoz, 3.0_prec, nz, zj, piz)
    zj(1:nz)=exp(zj(1:nz))/two
	beta=0.953690526499050     !0.953629_prec

    phi1_l=phi1*.20_prec
    phi1_h=phi1*1.80_prec
    gamma_l=gamma_psi*.20_prec
    gamma_h=gamma_psi*1.8_prec
	Psimin_l=Psimin*.95_prec
    Psimin_h=Psimin*1.05_prec
    Rbar_l=Rbar(1)*0.9840_prec
    Rbar_h=Rbar(1)*1.0160_prec

    sdeta_l=sdeta*0.90_prec
    sdeta_h=sdeta*1.10_prec
    beta_l=beta*0.988_prec
    beta_h=beta*1.012_prec
end if


    ! .. Write out calibration options ..
    IF(ID==0) THEN
    write(44,*) '--------------------------------'
    write(44,*)  'CALIBRATION SETTINGS '
    write(44,*) '--------------------------------'
    write(44,*) 'assigned param : '
    write(44,'(a15,f10.6)') 'r= ', rr
    write(44,'(a15,f10.6)') 'q0= ', q0
    write(44,*) 'direct param : '
    write(44,'(a15,f20.16)') 'delta= ' ,delta
    write(44,*) 'fixed param : '
    write(44,'(a15,f20.16)') 'rhoz= ',   rhoz
    write(44,'(a15,i10)')   'jzstar= ', jzstar
    write(44,*) '--------------------------------'
    write(44,*) '# calibrated param and targets: '
    write(44,*) 'number of param ', nparam
    write(44,*) 'number of targets ', mv
    write(44,*) '--------------------------------'
    write(44,*) 'search radius: '
    write(44,'(a15,f10.6)') 'rhobeg= ', rhobeg
    write(44,'(a15,f10.6)') 'rhoend= ', rhoend
    write(44,*) '--------------------------------'
    write(44,*) 'Internal calibration targets '
    write(44,'(a15,f10.6)') ' DebttoY_dat     ', DebttoY_dat
    write(44,'(a15,f10.6)') ' AtoY_dat     ', AtoY_dat
    write(44,'(a15,f10.6)') ' freqdef_dat  ', freqdef_dat
    write(44,'(a15,f10.6)') ' arrears_dat  ', arrears_dat
    write(44,'(a15,f10.6)') ' debtstdv_dat ', debtstdv_dat
    write(44,'(a15,f10.6)') ' dstdv_dat    ', dstdv_dat
    write(44,'(a15,f10.6)') ' sprstdv_dat  ', sprstdv_dat
    write(44,'(a15,f10.6)') ' logy_sd_dat ', logy_sd_dat
    write(44,'(a15,f10.6)') ' debtserv_dat ', debtserv_dat
    write(44,'(a15,f10.6)') ' debtserv_sd_dat ', debtserv_sd_dat

    write(44,*) '--------------------------------'
    write(44,*) 'Other calibration targets '
!*    write(44,'(a15,f10.6)') ' corrSpr_dat  ', corrSpr_dat
!*    write(44,'(a15,f10.6)') ' Spr_dat      ', Spr_dat
!*    write(44,'(a15,f10.6)') ' sdC_dat      ', sdC_dat
    write(44,'(a15,f10.6)') ' smalldef_dat ', smalldef_dat
    write(44,'(a15,f10.6)') ' logy_corr_dat ', logy_corr_dat
    write(44,*) '--------------------------------'
    write(44,*) 'Implied var '
    write(44,'(a15,f10.6)') ' duration     ', durat
    write(44,*) '--------------------------------'
    write(44,*) 'Initialisation parameters '
    write(44,'(a15,f10.6)') 'phi1     ',   phi1
    write(44,'(a15,f10.6)') 'gamma_psi',   gamma_psi
    write(44,'(a15,f10.6)') 'Psimin   ',   Psimin
    write(44,'(a15,f10.6)') 'beta     ',   beta
    write(44,'(a15,f10.6)') 'Rbar(1)  ',   Rbar(1)
    write(44,'(a15,f20.16)') 'sdeta= ',    sdeta
    write(44,*) '--------------------------------'
    write(44,*) 'Bounds for parameters '
    write(44,'(a15,2f10.6)') 'phi1     ',   phi1_l  ,  phi1_h
    write(44,'(a15,2f10.6)') 'gamma_psi',   gamma_l ,  gamma_h
    write(44,'(a15,2f10.6)') 'Psimin   ',   Psimin_l,  Psimin_h
    write(44,'(a15,2f10.6)') 'beta     ',   beta_l  ,  beta_h
    write(44,'(a15,2f10.6)') 'Rbar(1)  ',   Rbar_l  ,  Rbar_h
    write(44,'(a15,2f10.6)') 'sdeta     ',   sdeta_l  ,  sdeta_h
    write(44,*) '--------------------------------'
    END IF

    ! .. Normalise parameters ..
     param(1)=(phi1-phi1_l)/(phi1_h-phi1_l)
     param(2)=(gamma_psi-gamma_l)/(gamma_h-gamma_l)
     param(3)=(Psimin-Psimin_l)/(Psimin_h-Psimin_l)
     param(4)=(beta-beta_l)/(beta_h-beta_l)
     param(5)=(Rbar(1)-Rbar_l)/(Rbar_h-Rbar_l)
     param(6)=(sdeta-sdeta_l)/(sdeta_h-sdeta_l)

     paraml(:)=0.0_prec
     paramu(:)=1.0_prec

    ! .. Header of table ..
    IF(ID==0) THEN
    write(44,*)
    write(44,'(a6,11a9,3a6,6a7)') 'step',  'Rbar',  'phi1', 'gamma',  'Psimin', 'beta ', 'sdeta', 'loss', &
            & 'AtoY', 'Spr', 'freqdef', 'arrears', &
            & 'defsd ', 'sprsd ', &
            & 'debtsd', &
            & 'r_yspr', 'sdC', &
            & 'smalld', 'y sd', 'serv', 'servsd'
    END IF

    ! .. bobyqa minimisation ..
    step_calib=1
    call bobyqa (nparam, npt, param, paraml, paramu, rhobeg,rhoend,iprint,maxfun)
    IF(ID==0) THEN
    write(44,*)
    write(44,'(a25,f9.4)') 'Sd log inc ', sqrt(logy_var)
    write(44,'(a25,f9.4)') 'Autocorr log inc ', logy_corr
    write(44,*) 'COMPLETED! '
    END IF

     ! .. report final outcome ..
    IF(ID==0) THEN
    write(44,*) 'param phi, gam, Psimin, beta, Rbar, sdeta ', &
        &   (phi1_h-phi1_l)*param(1)+phi1_l, (gamma_h-gamma_l)*param(2)+gamma_l, &
        &   (Psimin_h-Psimin_l)*param(3)+Psimin_l, & !13jan15
        &   (beta_h-beta_l)*param(4)+beta_l, &
        &   (Rbar_h-Rbar_l)*param(5)+Rbar_l, &
        &   (sdeta_h-sdeta_l)*param(6)+sdeta_l
    END IF

    ! .. recompute calibrated outcomes ..
    call calfun(nparam, param, val_bobyqa)
    IF(ID==0) THEN
    write(44,*) 'param from dfovec ', phi1,  gamma_psi, Psimin, beta,  Rbar(1), sdeta
    END IF

 end subroutine calib_bobyqa_case8

! ***************************************************************
end MODULE mostly


PROGRAM main
  !******* activate main module *******
  use mostly
  use bobyqa_module !04jan21
  implicit none
  integer :: iter_barg !08jan14



	!******* initialization mpi environment ******* !mpi 02mar16
	!initialization of mpi environment
	call mpi_init(ierror)
	!obtain id for each node
	call mpi_comm_rank(mpi_comm_world, id, ierror)
	!returns the number of nodes
	call mpi_comm_size(mpi_comm_world, nproc, ierror)
	!***********************************************



    call readinfo
    call allocstuff

    call mappings_mpi !mpi

    ! **************** SOLVE EQUIL (NO CALIBRATION) *****************
    call initstuff
    call stat_distr !15jun17
    call prices_iter

 IF(ID==0) THEN !10jan18
    call graph2d_params
!    call graph2d_D
!    call graph2d_Doffgrid
!    call graph2d_D01
!    call graph2d_BD
!    call graph2d_BND
!    call graph2d_vND
!    call graph2d_v
    call graph2d_eps_Apr
    if(draw_3period.eq.1) call graph2d_y_Apr !03mar16
    call graph2d_Q

    call simul_paths  !(simulsize) !18feb17
    if((doIRF.eq.2).or.(doIRF.eq.3) &
        & .or.(doIRF.eq.4).or.(doIRF.eq.5).or.(doIRF.eq.6)) &
        &   call stochsimul_IRF(ntimeIRF,npathsIRF)
    !call stochsimul_IRF(3000,25000) !12feb17
    if(doIRF.eq.1) call simul_IRF !05mar16

    if(dowelf.eq.1) call write_welf !11sep21 !25oct21

!    call simul_ARG !20sep14
!    call graph_front !25jun13

!        call graph3d_V

 END IF !DD==0

    ! **************** END EQUIL (NO CALIBRATION) *****************

    ! **********************  CALIBRATION - BOBYQA new ********************
!!*    !14feb21
!!*    if(calibrcase.eq.1) then
!!*        call calib_bobyqa_case1
!!*    else if(calibrcase.eq.2) then
!!*        call calib_bobyqa_case2
!!*    else if(calibrcase.eq.3) then
!!*        call calib_bobyqa_case3
!!*    else if(calibrcase.eq.4) then
!!*        call calib_bobyqa_case4
!!*    else if(calibrcase.eq.5) then
!!*        call calib_bobyqa_case5
!!*    else if(calibrcase.eq.6) then
!!*        call calib_bobyqa_case6
!!*    else if(calibrcase.eq.7) then
!!*        call calib_bobyqa_case7
!!*    else if(calibrcase.eq.8) then
!!*        call calib_bobyqa_case8  !12oct21
!!*    end if
    ! **********************  END CALIBRATION - BOBYQA new ********************




	!******* finalize mpi environment !mpi *******
	call mpi_finalize(ierror)
	!***********************************************


end PROGRAM main
